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