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