]> git.vpit.fr Git - perl/modules/Variable-Magic.git/blob - Magic.xs
19eb15c18f03262393b4f9b482f5c71e0bf8ddde
[perl/modules/Variable-Magic.git] / Magic.xs
1 /* This file is part of the Variable::Magic Perl module.
2  * See http://search.cpan.org/dist/Variable-Magic/ */
3
4 #include <stdarg.h> /* <va_list>, va_{start,arg,end}, ... */
5
6 #include <stdio.h>  /* sprintf() */
7
8 #define PERL_NO_GET_CONTEXT
9 #include "EXTERN.h"
10 #include "perl.h"
11 #include "XSUB.h"
12
13 #define __PACKAGE__ "Variable::Magic"
14
15 #define PERL_VERSION_GE(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
16
17 #define PERL_VERSION_LE(R, V, S) (PERL_REVISION < (R) || (PERL_REVISION == (R) && (PERL_VERSION < (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION <= (S))))))
18
19 #ifndef VMG_PERL_PATCHLEVEL
20 # ifdef PERL_PATCHNUM
21 #  define VMG_PERL_PATCHLEVEL PERL_PATCHNUM
22 # else
23 #  define VMG_PERL_PATCHLEVEL 0
24 # endif
25 #endif
26
27 #define VMG_HAS_PERL_OR(P, R, V, S) ((VMG_PERL_PATCHLEVEL >= (P)) || (!VMG_PERL_PATCHLEVEL && PERL_VERSION_GE((R), (V), (S))))
28
29 #define VMG_HAS_PERL_AND(P, R, V, S) (PERL_VERSION_GE((R), (V), (S)) && (!VMG_PERL_PATCHLEVEL || (VMG_PERL_PATCHLEVEL >= (P))))
30
31 /* --- Threads and multiplicity -------------------------------------------- */
32
33 #ifndef NOOP
34 # define NOOP
35 #endif
36
37 #ifndef dNOOP
38 # define dNOOP
39 #endif
40
41 #ifndef VMG_MULTIPLICITY
42 # if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT)
43 #  define VMG_MULTIPLICITY 1
44 # else
45 #  define VMG_MULTIPLICITY 0
46 # endif
47 #endif
48 #if VMG_MULTIPLICITY && !defined(tTHX)
49 # define tTHX PerlInterpreter*
50 #endif
51
52 #if VMG_MULTIPLICITY && defined(USE_ITHREADS) && defined(dMY_CXT) && defined(MY_CXT) && defined(START_MY_CXT) && defined(MY_CXT_INIT) && (defined(MY_CXT_CLONE) || defined(dMY_CXT_SV))
53 # define VMG_THREADSAFE 1
54 # ifndef MY_CXT_CLONE
55 #  define MY_CXT_CLONE \
56     dMY_CXT_SV;                                                      \
57     my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1)); \
58     Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t); \
59     sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
60 # endif
61 #else
62 # define VMG_THREADSAFE 0
63 # undef  dMY_CXT
64 # define dMY_CXT      dNOOP
65 # undef  MY_CXT
66 # define MY_CXT       vmg_globaldata
67 # undef  START_MY_CXT
68 # define START_MY_CXT STATIC my_cxt_t MY_CXT;
69 # undef  MY_CXT_INIT
70 # define MY_CXT_INIT  NOOP
71 # undef  MY_CXT_CLONE
72 # define MY_CXT_CLONE NOOP
73 #endif
74
75 #if VMG_THREADSAFE
76
77 STATIC SV *vmg_clone(pTHX_ SV *sv, tTHX owner) {
78 #define vmg_clone(P, O) vmg_clone(aTHX_ (P), (O))
79  CLONE_PARAMS param;
80  param.stashes    = NULL; /* don't need it unless sv is a PVHV */
81  param.flags      = 0;
82  param.proto_perl = owner;
83  return sv_dup(sv, &param);
84 }
85
86 #endif /* VMG_THREADSAFE */
87
88 /* --- Compatibility ------------------------------------------------------- */
89
90 #ifndef Newx
91 # define Newx(v, n, c) New(0, v, n, c)
92 #endif
93
94 #ifndef SvMAGIC_set
95 # define SvMAGIC_set(sv, val) (SvMAGIC(sv) = (val))
96 #endif
97
98 #ifndef mPUSHi
99 # define mPUSHi(I) PUSHs(sv_2mortal(newSViv(I)))
100 #endif
101
102 #ifndef PERL_MAGIC_ext
103 # define PERL_MAGIC_ext '~'
104 #endif
105
106 #ifndef MGf_COPY
107 # define MGf_COPY 0
108 #endif
109
110 #ifndef MGf_DUP
111 # define MGf_DUP 0
112 #endif
113
114 #ifndef MGf_LOCAL
115 # define MGf_LOCAL 0
116 #endif
117
118 /* uvar magic and Hash::Util::FieldHash were commited with p28419 */
119 #if VMG_HAS_PERL_AND(28419, 5, 9, 4)
120 # define VMG_UVAR 1
121 #else
122 # define VMG_UVAR 0
123 #endif
124
125 #if !defined(VMG_COMPAT_ARRAY_PUSH_NOLEN) && VMG_HAS_PERL_OR(25854, 5, 9, 3)
126 # define VMG_COMPAT_ARRAY_PUSH_NOLEN 1
127 #else
128 # define VMG_COMPAT_ARRAY_PUSH_NOLEN 0
129 #endif
130
131 /* since 5.9.5 - see #43357 */
132 #if VMG_HAS_PERL_OR(31473, 5, 9, 5)
133 # define VMG_COMPAT_ARRAY_UNDEF_CLEAR 1
134 #else
135 # define VMG_COMPAT_ARRAY_UNDEF_CLEAR 0
136 #endif
137
138 #if VMG_HAS_PERL_OR(32969, 5, 11, 0)
139 # define VMG_COMPAT_SCALAR_LENGTH_NOLEN 1
140 #else
141 # define VMG_COMPAT_SCALAR_LENGTH_NOLEN 0
142 #endif
143
144 #if VMG_UVAR
145
146 /* Bug-free mg_magical - see http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2008-01/msg00036.html - but specialized to our needs. */
147 STATIC void vmg_sv_magicuvar(pTHX_ SV *sv, const char *uf, I32 len) {
148 #define vmg_sv_magicuvar(S, U, L) vmg_sv_magicuvar(aTHX_ (S), (U), (L))
149  const MAGIC* mg;
150  sv_magic(sv, NULL, PERL_MAGIC_uvar, uf, len);
151  /* uvar magic has set and get magic, hence this has set SVs_GMG and SVs_SMG. */
152  PERL_UNUSED_CONTEXT;
153  if ((mg = SvMAGIC(sv))) {
154   SvRMAGICAL_off(sv);
155   do {
156    const MGVTBL* const vtbl = mg->mg_virtual;
157    if (vtbl) {
158     if (vtbl->svt_clear) {
159      SvRMAGICAL_on(sv);
160      break;
161     }
162    }
163   } while ((mg = mg->mg_moremagic));
164  }
165 }
166
167 #endif /* VMG_UVAR */
168
169 /* --- Context-safe global data -------------------------------------------- */
170
171 #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
172
173 typedef HV * my_cxt_t;
174
175 START_MY_CXT
176
177 /* --- Signatures ---------------------------------------------------------- */
178
179 #define SIG_MIN ((U16) (1u << 8))
180 #define SIG_MAX ((U16) ((1u << 16) - 1))
181 #define SIG_NBR (SIG_MAX - SIG_MIN + 1)
182 #define SIG_WIZ ((U16) ((1u << 8) - 1))
183
184 /* ... Generate signatures ................................................. */
185
186 STATIC U16 vmg_gensig(pTHX) {
187 #define vmg_gensig() vmg_gensig(aTHX)
188  U16 sig;
189  char buf[8];
190  dMY_CXT;
191
192  do {
193   sig = SIG_NBR * Drand01() + SIG_MIN;
194  } while (hv_exists(MY_CXT, buf, sprintf(buf, "%u", sig)));
195
196  return sig;
197 }
198
199 /* --- MGWIZ structure ----------------------------------------------------- */
200
201 typedef struct {
202  MGVTBL *vtbl;
203  U16 sig;
204  U16 uvar;
205  SV *cb_data;
206  SV *cb_get, *cb_set, *cb_len, *cb_clear, *cb_free;
207 #if MGf_COPY
208  SV *cb_copy;
209 #endif /* MGf_COPY */
210 #if MGf_DUP
211  SV *cb_dup;
212 #endif /* MGf_DUP */
213 #if MGf_LOCAL
214  SV *cb_local;
215 #endif /* MGf_LOCAL */
216 #if VMG_UVAR
217  SV *cb_fetch, *cb_store, *cb_exists, *cb_delete;
218 #endif /* VMG_UVAR */
219 #if VMG_MULTIPLICITY
220  tTHX owner;
221 #endif /* VMG_MULTIPLICITY */
222 } MGWIZ;
223
224 #define MGWIZ2SV(W) (newSVuv(PTR2UV(W)))
225 #define SV2MGWIZ(S) (INT2PTR(MGWIZ*, SvUVX((SV *) (S))))
226
227 /* ... Construct private data .............................................. */
228
229 STATIC SV *vmg_data_new(pTHX_ SV *ctor, SV *sv, AV *args) {
230 #define vmg_data_new(C, S, A) vmg_data_new(aTHX_ (C), (S), (A))
231  SV *nsv;
232  I32 i, alen = (args == NULL) ? 0 : av_len(args);
233
234  dSP;
235  int count;
236
237  ENTER;
238  SAVETMPS;
239
240  PUSHMARK(SP);
241  EXTEND(SP, alen + 1);
242  PUSHs(sv_2mortal(newRV_inc(sv)));
243  for (i = 0; i < alen; ++i)
244   PUSHs(*av_fetch(args, i, 0));
245  PUTBACK;
246
247  count = call_sv(ctor, G_SCALAR);
248
249  SPAGAIN;
250
251  if (count != 1) { croak("Callback needs to return 1 scalar\n"); }
252  nsv = POPs;
253 #if PERL_VERSION_LE(5, 8, 2)
254  nsv = sv_newref(nsv); /* Workaround some bug in SvREFCNT_inc() */
255 #else
256  SvREFCNT_inc(nsv);    /* Or it will be destroyed in FREETMPS */
257 #endif
258
259  PUTBACK;
260
261  FREETMPS;
262  LEAVE;
263
264  return nsv;
265 }
266
267 STATIC SV *vmg_data_get(SV *sv, U16 sig) {
268  MAGIC *mg, *moremagic;
269
270  if (SvTYPE(sv) >= SVt_PVMG) {
271   for (mg = SvMAGIC(sv); mg; mg = moremagic) {
272    moremagic = mg->mg_moremagic;
273    if ((mg->mg_type == PERL_MAGIC_ext) && (mg->mg_private == sig)) { break; }
274   }
275   if (mg) { return mg->mg_obj; }
276  }
277
278  return NULL;
279
280
281 /* ... Magic cast/dispell .................................................. */
282
283 #if VMG_UVAR
284 STATIC I32 vmg_svt_val(pTHX_ IV, SV *);
285
286 STATIC void vmg_uvar_del(SV *sv, MAGIC *prevmagic, MAGIC *mg, MAGIC *moremagic) {
287  if (prevmagic) {
288   prevmagic->mg_moremagic = moremagic;
289  } else {
290   SvMAGIC_set(sv, moremagic);
291  }
292  mg->mg_moremagic = NULL;
293  Safefree(mg->mg_ptr);
294  Safefree(mg);
295 }
296 #endif /* VMG_UVAR */
297
298 STATIC UV vmg_cast(pTHX_ SV *sv, SV *wiz, AV *args) {
299 #define vmg_cast(S, W, A) vmg_cast(aTHX_ (S), (W), (A))
300  MAGIC *mg = NULL, *moremagic = NULL;
301  MGWIZ *w;
302  SV *data;
303
304  w = SV2MGWIZ(wiz);
305
306  if (SvTYPE(sv) >= SVt_PVMG) {
307   for (mg = SvMAGIC(sv); mg; mg = moremagic) {
308    moremagic = mg->mg_moremagic;
309    if ((mg->mg_type == PERL_MAGIC_ext) && (mg->mg_private == w->sig)) { break; }
310   }
311   if (mg) { return 1; }
312  }
313
314  data = (w->cb_data) ? vmg_data_new(w->cb_data, sv, args) : NULL;
315  mg = sv_magicext(sv, data, PERL_MAGIC_ext, w->vtbl, (const char *) wiz, HEf_SVKEY);
316  mg->mg_private = w->sig;
317 #if MGf_COPY
318  if (w->cb_copy)
319   mg->mg_flags |= MGf_COPY;
320 #endif /* MGf_COPY */
321 #if 0 /* MGf_DUP */
322  if (w->cb_dup)
323   mg->mg_flags |= MGf_DUP;
324 #endif /* MGf_DUP */
325 #if MGf_LOCAL
326  if (w->cb_local)
327   mg->mg_flags |= MGf_LOCAL;
328 #endif /* MGf_LOCAL */
329
330 #if VMG_UVAR
331  if (w->uvar && SvTYPE(sv) >= SVt_PVHV) {
332   MAGIC *prevmagic;
333   int add_uvar = 1;
334   struct ufuncs uf[2];
335
336   uf[0].uf_val   = vmg_svt_val;
337   uf[0].uf_set   = NULL;
338   uf[0].uf_index = 0;
339   uf[1].uf_val   = NULL;
340   uf[1].uf_set   = NULL;
341   uf[1].uf_index = 0;
342
343   /* One uvar magic in the chain is enough. */
344   for (prevmagic = NULL, mg = SvMAGIC(sv); mg; prevmagic = mg, mg = moremagic) {
345    moremagic = mg->mg_moremagic;
346    if (mg->mg_type == PERL_MAGIC_uvar) { break; }
347   }
348
349   if (mg) { /* Found another uvar magic. */
350    struct ufuncs *olduf = (struct ufuncs *) mg->mg_ptr;
351    if (olduf->uf_val == vmg_svt_val) {
352     /* It's our uvar magic, nothing to do. */
353     add_uvar = 0;
354    } else {
355     /* It's another uvar magic, backup it and replace it by ours. */
356     uf[1] = *olduf;
357     vmg_uvar_del(sv, prevmagic, mg, moremagic);
358    }
359   }
360
361   if (add_uvar) {
362    vmg_sv_magicuvar(sv, (const char *) &uf, sizeof(uf));
363   }
364
365  }
366 #endif /* VMG_UVAR */
367
368  return 1;
369 }
370
371 STATIC UV vmg_dispell(pTHX_ SV *sv, U16 sig) {
372 #define vmg_dispell(S, Z) vmg_dispell(aTHX_ (S), (Z))
373 #if VMG_UVAR
374  U32 uvars = 0;
375 #endif /* VMG_UVAR */
376  MAGIC *mg, *prevmagic, *moremagic = NULL;
377
378  if (SvTYPE(sv) < SVt_PVMG) { return 0; }
379
380  for (prevmagic = NULL, mg = SvMAGIC(sv); mg; prevmagic = mg, mg = moremagic) {
381   moremagic = mg->mg_moremagic;
382   if (mg->mg_type == PERL_MAGIC_ext) {
383    if (mg->mg_private == sig) {
384 #if VMG_UVAR
385     /* If the current has no uvar, short-circuit uvar deletion. */
386     uvars = (SV2MGWIZ(mg->mg_ptr)->uvar) ? (uvars + 1) : 0;
387 #endif /* VMG_UVAR */
388     break;
389 #if VMG_UVAR
390    } else if ((mg->mg_private >= SIG_MIN) &&
391               (mg->mg_private <= SIG_MAX) &&
392                SV2MGWIZ(mg->mg_ptr)->uvar) {
393     ++uvars;
394     /* We can't break here since we need to find the ext magic to delete. */
395 #endif /* VMG_UVAR */
396    }
397   }
398  }
399  if (!mg) { return 0; }
400
401  if (prevmagic) {
402   prevmagic->mg_moremagic = moremagic;
403  } else {
404   SvMAGIC_set(sv, moremagic);
405  }
406  mg->mg_moremagic = NULL;
407
408  if (mg->mg_obj != sv) { SvREFCNT_dec(mg->mg_obj); } /* Destroy private data */
409  SvREFCNT_dec((SV *) mg->mg_ptr); /* Unreference the wizard */
410  Safefree(mg);
411
412 #if VMG_UVAR
413  if (uvars == 1 && SvTYPE(sv) >= SVt_PVHV) {
414   /* mg was the first ext magic in the chain that had uvar */
415
416   for (mg = moremagic; mg; mg = mg->mg_moremagic) {
417    if ((mg->mg_type == PERL_MAGIC_ext) &&
418        (mg->mg_private >= SIG_MIN) &&
419        (mg->mg_private <= SIG_MAX) &&
420         SV2MGWIZ(mg->mg_ptr)->uvar) {
421     ++uvars;
422     break;
423    }
424   }
425
426   if (uvars == 1) {
427    struct ufuncs *uf;
428    for (prevmagic = NULL, mg = SvMAGIC(sv); mg; prevmagic = mg, mg = moremagic){
429     moremagic = mg->mg_moremagic;
430     if (mg->mg_type == PERL_MAGIC_uvar) { break; }
431    }
432    /* assert(mg); */
433    uf = (struct ufuncs *) mg->mg_ptr;
434    /* assert(uf->uf_val == vmg_svt_val); */
435    if (uf[1].uf_val || uf[1].uf_set) {
436     /* Revert the original uvar magic. */
437     uf[0] = uf[1];
438     Renew(uf, 1, struct ufuncs);
439     mg->mg_ptr = (char *) uf;
440     mg->mg_len = sizeof(struct ufuncs);
441    } else {
442     /* Remove the uvar magic. */
443     vmg_uvar_del(sv, prevmagic, mg, moremagic);
444    }
445   }
446  }
447 #endif /* VMG_UVAR */
448
449  return 1;
450 }
451
452 /* ... svt callbacks ....................................................... */
453
454 STATIC int vmg_cb_call(pTHX_ SV *cb, SV *sv, SV *data, unsigned int args, ...) {
455  va_list ap;
456  SV *svr;
457  int ret;
458  unsigned int i;
459
460  dSP;
461  int count;
462
463  ENTER;
464  SAVETMPS;
465
466  PUSHMARK(SP);
467  EXTEND(SP, args + 2);
468  PUSHs(sv_2mortal(newRV_inc(sv)));
469  PUSHs(data ? data : &PL_sv_undef);
470  va_start(ap, args);
471  for (i = 0; i < args; ++i) {
472   SV *sva = va_arg(ap, SV *);
473   PUSHs(sva ? sva : &PL_sv_undef);
474  }
475  va_end(ap);
476  PUTBACK;
477
478  count = call_sv(cb, G_SCALAR);
479
480  SPAGAIN;
481
482  if (count != 1) { croak("Callback needs to return 1 scalar\n"); }
483  svr = POPs;
484  ret = SvOK(svr) ? SvIV(svr) : 0;
485
486  PUTBACK;
487
488  FREETMPS;
489  LEAVE;
490
491  return ret;
492 }
493
494 #define vmg_cb_call1(I, S, D)         vmg_cb_call(aTHX_ (I), (S), (D), 0)
495 #define vmg_cb_call2(I, S, D, S2)     vmg_cb_call(aTHX_ (I), (S), (D), 1, (S2))
496 #define vmg_cb_call3(I, S, D, S2, S3) vmg_cb_call(aTHX_ (I), (S), (D), 2, (S2), (S3))
497
498 STATIC int vmg_svt_get(pTHX_ SV *sv, MAGIC *mg) {
499  return vmg_cb_call1(SV2MGWIZ(mg->mg_ptr)->cb_get, sv, mg->mg_obj);
500 }
501
502 STATIC int vmg_svt_set(pTHX_ SV *sv, MAGIC *mg) {
503  return vmg_cb_call1(SV2MGWIZ(mg->mg_ptr)->cb_set, sv, mg->mg_obj);
504 }
505
506 STATIC U32 vmg_svt_len(pTHX_ SV *sv, MAGIC *mg) {
507  SV *svr;
508  I32 len;
509  U32 ret;
510
511  dSP;
512  int count;
513
514  ENTER;
515  SAVETMPS;
516
517  PUSHMARK(SP);
518  EXTEND(SP, 3);
519  PUSHs(sv_2mortal(newRV_inc(sv)));
520  PUSHs(mg->mg_obj ? mg->mg_obj : &PL_sv_undef);
521  if (SvTYPE(sv) == SVt_PVAV) {
522   len = av_len((AV *) sv) + 1;
523   mPUSHi(len);
524  } else {
525   len = 1;
526   PUSHs(&PL_sv_undef);
527  }
528  PUTBACK;
529
530  count = call_sv(SV2MGWIZ(mg->mg_ptr)->cb_len, G_SCALAR);
531
532  SPAGAIN;
533
534  if (count != 1) { croak("Callback needs to return 1 scalar\n"); }
535  svr = POPs;
536  ret = SvOK(svr) ? SvUV(svr) : len;
537
538  PUTBACK;
539
540  FREETMPS;
541  LEAVE;
542
543  return ret - 1;
544 }
545
546 STATIC int vmg_svt_clear(pTHX_ SV *sv, MAGIC *mg) {
547  return vmg_cb_call1(SV2MGWIZ(mg->mg_ptr)->cb_clear, sv, mg->mg_obj);
548 }
549
550 STATIC int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) {
551  /* So that it can survive tmp cleanup in vmg_cb_call */
552  SvREFCNT_inc(sv);
553 #if !VMG_HAS_PERL_AND(32686, 5, 11, 0)
554  /* The previous magic tokens were freed but the magic chain wasn't updated, so
555   * if you access the sv from the callback the old deleted magics will trigger
556   * and cause memory misreads. Change 32686 solved it that way : */
557  SvMAGIC_set(sv, mg);
558 #endif
559  /* Perl_mg_free will get rid of the magic and decrement mg->mg_obj and
560   * mg->mg_ptr reference count */
561  return vmg_cb_call1(SV2MGWIZ(mg->mg_ptr)->cb_free, sv, mg->mg_obj);
562 }
563
564 #if MGf_COPY
565 STATIC int vmg_svt_copy(pTHX_ SV *sv, MAGIC *mg, SV *nsv, const char *key,
566 # if VMG_HAS_PERL_AND(33256, 5, 11, 0)
567   I32 keylen
568 # else
569   int keylen
570 # endif
571  ) {
572  SV *keysv;
573  int ret;
574
575  if (keylen == HEf_SVKEY) {
576   keysv = (SV *) key;
577  } else {
578   keysv = newSVpvn(key, keylen);
579  }
580
581  ret = vmg_cb_call3(SV2MGWIZ(mg->mg_ptr)->cb_copy, sv, mg->mg_obj, keysv, nsv);
582
583  if (keylen != HEf_SVKEY) {
584   SvREFCNT_dec(keysv);
585  }
586
587  return ret;
588 }
589 #endif /* MGf_COPY */
590
591 #if 0 /*  MGf_DUP */
592 STATIC int vmg_svt_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) {
593  return 0;
594 }
595 #endif /* MGf_DUP */
596
597 #if MGf_LOCAL
598 STATIC int vmg_svt_local(pTHX_ SV *nsv, MAGIC *mg) {
599  return vmg_cb_call1(SV2MGWIZ(mg->mg_ptr)->cb_local, nsv, mg->mg_obj);
600 }
601 #endif /* MGf_LOCAL */
602
603 #if VMG_UVAR
604 STATIC I32 vmg_svt_val(pTHX_ IV action, SV *sv) {
605  struct ufuncs *uf;
606  MAGIC *mg;
607  SV *key = NULL;
608
609  mg  = mg_find(sv, PERL_MAGIC_uvar);
610  /* mg can't be NULL or we wouldn't be there. */
611  key = mg->mg_obj;
612  uf  = (struct ufuncs *) mg->mg_ptr;
613
614  if (uf[1].uf_val != NULL) { uf[1].uf_val(aTHX_ action, sv); }
615  if (uf[1].uf_set != NULL) { uf[1].uf_set(aTHX_ action, sv); }
616
617  action &= HV_FETCH_ISSTORE | HV_FETCH_ISEXISTS | HV_FETCH_LVALUE | HV_DELETE;
618  for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
619   MGWIZ *w;
620   if ((mg->mg_type != PERL_MAGIC_ext)
621    || (mg->mg_private < SIG_MIN)
622    || (mg->mg_private > SIG_MAX)) { continue; }
623   w = SV2MGWIZ(mg->mg_ptr);
624   if (!w->uvar) { continue; }
625   switch (action) {
626    case 0:
627     if (w->cb_fetch)  { vmg_cb_call2(w->cb_fetch,  sv, mg->mg_obj, key); }
628     break;
629    case HV_FETCH_ISSTORE:
630    case HV_FETCH_LVALUE:
631    case (HV_FETCH_ISSTORE|HV_FETCH_LVALUE):
632     if (w->cb_store)  { vmg_cb_call2(w->cb_store,  sv, mg->mg_obj, key); }
633     break;
634    case HV_FETCH_ISEXISTS:
635     if (w->cb_exists) { vmg_cb_call2(w->cb_exists, sv, mg->mg_obj, key); }
636     break;
637    case HV_DELETE:
638     if (w->cb_delete) { vmg_cb_call2(w->cb_delete, sv, mg->mg_obj, key); }
639     break;
640   }
641  }
642
643  return 0;
644 }
645 #endif /* VMG_UVAR */
646
647 /* ... Wizard destructor ................................................... */
648
649 STATIC int vmg_wizard_free(pTHX_ SV *wiz, MAGIC *mg) {
650  char buf[8];
651  MGWIZ *w;
652
653  if (PL_dirty) /* during global destruction, the context is already freed */
654   return 0;
655
656  w = SV2MGWIZ(wiz);
657 #if VMG_MULTIPLICITY
658  if (w->owner != aTHX)
659   return 0;
660  w->owner = NULL;
661 #endif /* VMG_MULTIPLICITY */
662
663  {
664   dMY_CXT;
665   if (hv_delete(MY_CXT, buf, sprintf(buf, "%u", w->sig), 0) != wiz)
666    return 0;
667  }
668  SvFLAGS(wiz) |= SVf_BREAK;
669  FREETMPS;
670
671  if (w->cb_data  != NULL) { SvREFCNT_dec(SvRV(w->cb_data)); }
672  if (w->cb_get   != NULL) { SvREFCNT_dec(SvRV(w->cb_get)); }
673  if (w->cb_set   != NULL) { SvREFCNT_dec(SvRV(w->cb_set)); }
674  if (w->cb_len   != NULL) { SvREFCNT_dec(SvRV(w->cb_len)); }
675  if (w->cb_clear != NULL) { SvREFCNT_dec(SvRV(w->cb_clear)); }
676  if (w->cb_free  != NULL) { SvREFCNT_dec(SvRV(w->cb_free)); }
677 #if MGf_COPY
678  if (w->cb_copy  != NULL) { SvREFCNT_dec(SvRV(w->cb_copy)); }
679 #endif /* MGf_COPY */
680 #if 0 /* MGf_DUP */
681  if (w->cb_dup   != NULL) { SvREFCNT_dec(SvRV(w->cb_dup)); }
682 #endif /* MGf_DUP */
683 #if MGf_LOCAL
684  if (w->cb_local != NULL) { SvREFCNT_dec(SvRV(w->cb_local)); }
685 #endif /* MGf_LOCAL */
686 #if VMG_UVAR
687  if (w->cb_fetch  != NULL) { SvREFCNT_dec(SvRV(w->cb_fetch)); }
688  if (w->cb_store  != NULL) { SvREFCNT_dec(SvRV(w->cb_store)); }
689  if (w->cb_exists != NULL) { SvREFCNT_dec(SvRV(w->cb_exists)); }
690  if (w->cb_delete != NULL) { SvREFCNT_dec(SvRV(w->cb_delete)); }
691 #endif /* VMG_UVAR */
692
693  Safefree(w->vtbl);
694  Safefree(w);
695
696  return 0;
697 }
698
699 STATIC MGVTBL vmg_wizard_vtbl = {
700  NULL,            /* get */
701  NULL,            /* set */
702  NULL,            /* len */
703  NULL,            /* clear */
704  vmg_wizard_free, /* free */
705 #if MGf_COPY
706  NULL,            /* copy */
707 #endif /* MGf_COPY */
708 #if MGf_DUP
709  NULL,            /* dup */
710 #endif /* MGf_DUP */
711 #if MGf_LOCAL
712  NULL,            /* local */
713 #endif /* MGf_LOCAL */
714 };
715
716 STATIC const char vmg_invalid_wiz[]    = "Invalid wizard object";
717 STATIC const char vmg_invalid_sv[]     = "Invalid variable";
718 STATIC const char vmg_invalid_sig[]    = "Invalid numeric signature";
719 STATIC const char vmg_wrongargnum[]    = "Wrong number of arguments";
720 STATIC const char vmg_toomanysigs[]    = "Too many magic signatures used";
721 STATIC const char vmg_argstorefailed[] = "Error while storing arguments";
722
723 STATIC U16 vmg_sv2sig(pTHX_ SV *sv) {
724 #define vmg_sv2sig(S) vmg_sv2sig(aTHX_ (S))
725  U16 sig;
726
727  if (SvIOK(sv)) {
728   sig = SvUVX(sv);
729  } else if (SvNOK(sv)) {
730   sig = SvNVX(sv);
731  } else if ((SvPOK(sv) && grok_number(SvPVX(sv), SvCUR(sv), NULL))) {
732   sig = SvUV(sv);
733  } else {
734   croak(vmg_invalid_sig);
735  }
736  if (sig < SIG_MIN) { sig += SIG_MIN; }
737  if (sig > SIG_MAX) { sig %= SIG_MAX + 1; }
738
739  return sig;
740 }
741
742 STATIC U16 vmg_wizard_sig(pTHX_ SV *wiz) {
743 #define vmg_wizard_sig(W) vmg_wizard_sig(aTHX_ (W))
744  char buf[8];
745  U16 sig;
746
747  if (SvROK(wiz)) {
748   sig = SV2MGWIZ(SvRV(wiz))->sig;
749  } else if (SvOK(wiz)) {
750   sig = vmg_sv2sig(wiz);
751  } else {
752   croak(vmg_invalid_wiz);
753  }
754
755  {
756   dMY_CXT;
757   if (!hv_fetch(MY_CXT, buf, sprintf(buf, "%u", sig), 0))
758    sig = 0;
759  }
760  return sig;
761 }
762
763 STATIC SV *vmg_wizard_wiz(pTHX_ SV *wiz) {
764 #define vmg_wizard_wiz(W) vmg_wizard_wiz(aTHX_ (W))
765  char buf[8];
766  SV **old;
767  U16 sig;
768
769  if (SvROK(wiz)) {
770   wiz = SvRV(wiz);
771 #if VMG_MULTIPLICITY
772   if (SV2MGWIZ(wiz)->owner == aTHX)
773    return wiz;
774 #endif /* VMG_MULTIPLICITY */
775   sig = SV2MGWIZ(wiz)->sig;
776  } else if (SvOK(wiz)) {
777   sig = vmg_sv2sig(wiz);
778  } else {
779   croak(vmg_invalid_wiz);
780  }
781
782  {
783   dMY_CXT;
784   return (old = hv_fetch(MY_CXT, buf, sprintf(buf, "%u", sig), 0))
785           ? *old : NULL;
786  }
787 }
788
789 #define VMG_SET_CB(S, N)              \
790  cb = (S);                            \
791  w->cb_ ## N = (SvOK(cb) && SvROK(cb)) ? newRV_inc(SvRV(cb)) : NULL;
792
793 #define VMG_SET_SVT_CB(S, N)          \
794  cb = (S);                            \
795  if (SvOK(cb) && SvROK(cb)) {         \
796   t->svt_ ## N = vmg_svt_ ## N;       \
797   w->cb_  ## N = newRV_inc(SvRV(cb)); \
798  } else {                             \
799   t->svt_ ## N = NULL;                \
800   w->cb_  ## N = NULL;                \
801  }
802
803 #if VMG_THREADSAFE
804
805 #define VMG_CLONE_CB(N) \
806  z->cb_ ## N = (w->cb_ ## N) ? newRV_noinc(vmg_clone(SvRV(w->cb_ ## N), \
807                                            w->owner))                   \
808                              : NULL;
809
810 STATIC MGWIZ *vmg_wizard_clone(pTHX_ const MGWIZ *w) {
811 #define vmg_wizard_clone(W) vmg_wizard_clone(aTHX_ (W))
812  MGVTBL *t;
813  MGWIZ *z;
814
815  Newx(t, 1, MGVTBL);
816  Copy(w->vtbl, t, 1, MGVTBL);
817
818  Newx(z, 1, MGWIZ);
819  VMG_CLONE_CB(data);
820  VMG_CLONE_CB(get);
821  VMG_CLONE_CB(set);
822  VMG_CLONE_CB(len);
823  VMG_CLONE_CB(clear);
824  VMG_CLONE_CB(free);
825 #if MGf_COPY
826  VMG_CLONE_CB(copy);
827 #endif /* MGf_COPY */
828 #if MGf_DUP
829  VMG_CLONE_CB(dup);
830 #endif /* MGf_DUP */
831 #if MGf_LOCAL
832  VMG_CLONE_CB(local);
833 #endif /* MGf_LOCAL */
834 #if VMG_UVAR
835  VMG_CLONE_CB(fetch);
836  VMG_CLONE_CB(store);
837  VMG_CLONE_CB(exists);
838  VMG_CLONE_CB(delete);
839 #endif /* VMG_UVAR */
840  z->owner = aTHX;
841  z->vtbl  = t;
842  z->sig   = w->sig;
843  z->uvar  = w->uvar;
844
845  return z;
846 }
847
848 #endif /* VMG_THREADSAFE */
849
850 /* --- XS ------------------------------------------------------------------ */
851
852 MODULE = Variable::Magic            PACKAGE = Variable::Magic
853
854 PROTOTYPES: ENABLE
855
856 BOOT:
857 {
858  HV *stash;
859  MY_CXT_INIT;
860  MY_CXT = newHV();
861  hv_iterinit(MY_CXT); /* Allocate iterator */
862  stash = gv_stashpv(__PACKAGE__, 1);
863  newCONSTSUB(stash, "SIG_MIN",   newSVuv(SIG_MIN));
864  newCONSTSUB(stash, "SIG_MAX",   newSVuv(SIG_MAX));
865  newCONSTSUB(stash, "SIG_NBR",   newSVuv(SIG_NBR));
866  newCONSTSUB(stash, "MGf_COPY",  newSVuv(MGf_COPY));
867  newCONSTSUB(stash, "MGf_DUP",   newSVuv(MGf_DUP));
868  newCONSTSUB(stash, "MGf_LOCAL", newSVuv(MGf_LOCAL));
869  newCONSTSUB(stash, "VMG_UVAR",  newSVuv(VMG_UVAR));
870  newCONSTSUB(stash, "VMG_COMPAT_ARRAY_PUSH_NOLEN",
871                     newSVuv(VMG_COMPAT_ARRAY_PUSH_NOLEN));
872  newCONSTSUB(stash, "VMG_COMPAT_ARRAY_UNDEF_CLEAR",
873                     newSVuv(VMG_COMPAT_ARRAY_UNDEF_CLEAR));
874  newCONSTSUB(stash, "VMG_COMPAT_SCALAR_LENGTH_NOLEN",
875                     newSVuv(VMG_COMPAT_SCALAR_LENGTH_NOLEN));
876  newCONSTSUB(stash, "VMG_PERL_PATCHLEVEL", newSVuv(VMG_PERL_PATCHLEVEL));
877  newCONSTSUB(stash, "VMG_THREADSAFE",      newSVuv(VMG_THREADSAFE));
878 }
879
880 void
881 CLONE(...)
882 PROTOTYPE: DISABLE
883 PREINIT:
884  HV *hv;
885 CODE:
886 #if VMG_THREADSAFE
887  {
888   HE *key;
889   dMY_CXT;
890   hv = newHV();
891   hv_iterinit(hv); /* Allocate iterator */
892   hv_iterinit(MY_CXT);
893   while ((key = hv_iternext(MY_CXT))) {
894    STRLEN len;
895    char *sig = HePV(key, len);
896    SV *sv;
897    MAGIC *mg;
898    sv = MGWIZ2SV(vmg_wizard_clone(SV2MGWIZ(HeVAL(key))));
899    mg = sv_magicext(sv, NULL, PERL_MAGIC_ext, &vmg_wizard_vtbl, NULL, 0);
900    mg->mg_private = SIG_WIZ;
901    SvREADONLY_on(sv);
902    hv_store(hv, sig, len, sv, HeHASH(key));
903   }
904  }
905  {
906   MY_CXT_CLONE;
907   MY_CXT = hv;
908  }
909 #endif /* VMG_THREADSAFE */
910
911 SV *_wizard(...)
912 PROTOTYPE: DISABLE
913 PREINIT:
914  I32 i = 0;
915  U16 sig;
916  char buf[8];
917  MGWIZ *w;
918  MGVTBL *t;
919  MAGIC *mg;
920  SV *sv;
921  SV *svsig;
922  SV *cb;
923 CODE:
924  dMY_CXT;
925
926  if (items != 7
927 #if MGf_COPY
928               + 1
929 #endif /* MGf_COPY */
930 #if MGf_DUP
931               + 1
932 #endif /* MGf_DUP */
933 #if MGf_LOCAL
934               + 1
935 #endif /* MGf_LOCAL */
936 #if VMG_UVAR
937               + 4
938 #endif /* VMG_UVAR */
939               ) { croak(vmg_wrongargnum); }
940
941  svsig = ST(i++);
942  if (SvOK(svsig)) {
943   SV **old;
944   sig = vmg_sv2sig(svsig);
945   if ((old = hv_fetch(MY_CXT, buf, sprintf(buf, "%u", sig), 0))) {
946    ST(0) = sv_2mortal(newRV_inc(*old));
947    XSRETURN(1);
948   }
949  } else {
950   if (HvKEYS(MY_CXT) >= SIG_NBR) { croak(vmg_toomanysigs); }
951   sig = vmg_gensig();
952  }
953  
954  Newx(t, 1, MGVTBL);
955  Newx(w, 1, MGWIZ);
956
957  VMG_SET_CB(ST(i++), data);
958  VMG_SET_SVT_CB(ST(i++), get);
959  VMG_SET_SVT_CB(ST(i++), set);
960  VMG_SET_SVT_CB(ST(i++), len);
961  VMG_SET_SVT_CB(ST(i++), clear);
962  VMG_SET_SVT_CB(ST(i++), free);
963 #if MGf_COPY
964  VMG_SET_SVT_CB(ST(i++), copy);
965 #endif /* MGf_COPY */
966 #if MGf_DUP
967  /* VMG_SET_SVT_CB(ST(i++), dup); */
968  i++;
969  t->svt_dup = NULL;
970  w->cb_dup  = NULL;
971 #endif /* MGf_DUP */
972 #if MGf_LOCAL
973  VMG_SET_SVT_CB(ST(i++), local);
974 #endif /* MGf_LOCAL */
975 #if VMG_UVAR
976  VMG_SET_CB(ST(i++), fetch);
977  VMG_SET_CB(ST(i++), store);
978  VMG_SET_CB(ST(i++), exists);
979  VMG_SET_CB(ST(i++), delete);
980 #endif /* VMG_UVAR */
981 #if VMG_MULTIPLICITY
982  w->owner = aTHX;
983 #endif /* VMG_MULTIPLICITY */
984
985  w->vtbl = t;
986  w->sig  = sig;
987 #if VMG_UVAR
988  w->uvar = (w->cb_fetch || w->cb_store || w->cb_exists || w->cb_delete);
989 #endif /* VMG_UVAR */
990
991  sv = MGWIZ2SV(w);
992  mg = sv_magicext(sv, NULL, PERL_MAGIC_ext, &vmg_wizard_vtbl, NULL, 0);
993  mg->mg_private = SIG_WIZ;
994  SvREADONLY_on(sv);
995
996  hv_store(MY_CXT, buf, sprintf(buf, "%u", sig), sv, 0);
997
998  RETVAL = newRV_noinc(sv);
999 OUTPUT:
1000  RETVAL
1001
1002 SV *gensig()
1003 PROTOTYPE:
1004 CODE:
1005  dMY_CXT;
1006  if (HvKEYS(MY_CXT) >= SIG_NBR) { croak(vmg_toomanysigs); }
1007  RETVAL = newSVuv(vmg_gensig());
1008 OUTPUT:
1009  RETVAL
1010
1011 SV *getsig(SV *wiz)
1012 PROTOTYPE: $
1013 CODE:
1014  if (!SvROK(wiz)) { croak(vmg_invalid_wiz); }
1015  RETVAL = newSVuv(SV2MGWIZ(SvRV(wiz))->sig);
1016 OUTPUT:
1017  RETVAL
1018
1019 SV *cast(SV *sv, SV *wiz, ...)
1020 PROTOTYPE: \[$@%&*]$@
1021 PREINIT:
1022  AV *args = NULL;
1023  SV *ret;
1024 CODE:
1025  wiz = vmg_wizard_wiz(wiz);
1026  if (!wiz)
1027   XSRETURN_UNDEF;
1028  if (items > 2) {
1029   I32 i;
1030   args = newAV();
1031   av_fill(args, items - 2);
1032   for (i = 2; i < items; ++i) {
1033    SV *arg = ST(i);
1034    SvREFCNT_inc(arg);
1035    if (av_store(args, i - 2, arg) == NULL) { croak(vmg_argstorefailed); }
1036   }
1037  }
1038  ret = newSVuv(vmg_cast(SvRV(sv), wiz, args));
1039  SvREFCNT_dec(args);
1040  RETVAL = ret;
1041 OUTPUT:
1042  RETVAL
1043
1044 SV *getdata(SV *sv, SV *wiz)
1045 PROTOTYPE: \[$@%&*]$
1046 PREINIT:
1047  SV *data;
1048  U16 sig;
1049 CODE:
1050  sig = vmg_wizard_sig(wiz);
1051  if (!sig)
1052   XSRETURN_UNDEF;
1053  data = vmg_data_get(SvRV(sv), sig);
1054  if (!data) { XSRETURN_UNDEF; }
1055  ST(0) = data;
1056  XSRETURN(1);
1057
1058 SV *dispell(SV *sv, SV *wiz)
1059 PROTOTYPE: \[$@%&*]$
1060 PREINIT:
1061  U16 sig;
1062 CODE:
1063  sig = vmg_wizard_sig(wiz);
1064  if (!sig)
1065   XSRETURN_UNDEF;
1066  RETVAL = newSVuv(vmg_dispell(SvRV(sv), sig));
1067 OUTPUT:
1068  RETVAL