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