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