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