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 (mg->mg_private == sig) {
 300 #if VMG_UVAR
 301     /* If the current has no uvar, short-circuit uvar deletion. */
 302     uvars = (SV2MGWIZ(mg->mg_ptr)->uvar) ? (uvars + 1) : 0;
 303 #endif /* VMG_UVAR */
 304     break;
 305 #if VMG_UVAR
 306    } else if ((mg->mg_private >= SIG_MIN) &&
 307               (mg->mg_private <= SIG_MAX) &&
 308                SV2MGWIZ(mg->mg_ptr)->uvar) {
 309     ++uvars;
 310     /* We can't break here since we need to find the ext magic to delete. */
 311 #endif /* VMG_UVAR */
 312    }
 313   }
 314  }
 315  if (!mg) { return 0; }
 316
 317  if (prevmagic) {
 318   prevmagic->mg_moremagic = moremagic;
 319  } else {
 320   SvMAGIC_set(sv, moremagic);
 321  }
 322  mg->mg_moremagic = NULL;
 323
 324  if (mg->mg_obj != sv) { SvREFCNT_dec(mg->mg_obj); } /* Destroy private data */
 325  SvREFCNT_dec((SV *) mg->mg_ptr); /* Unreference the wizard */
 326  Safefree(mg);
 327
 328 #if VMG_UVAR
 329  if (uvars == 1 && SvTYPE(sv) >= SVt_PVHV) {
 330   /* mg was the first ext magic in the chain that had uvar */
 331
 332   for (mg = moremagic; mg; mg = mg->mg_moremagic) {
 333    if ((mg->mg_type == PERL_MAGIC_ext) &&
 334        (mg->mg_private >= SIG_MIN) &&
 335        (mg->mg_private <= SIG_MAX) &&
 336         SV2MGWIZ(mg->mg_ptr)->uvar) {
 337     ++uvars;
 338     break;
 339    }
 340   }
 341
 342   if (uvars == 1) {
 343    struct ufuncs *uf;
 344    for (prevmagic = NULL, mg = SvMAGIC(sv); mg; prevmagic = mg, mg = moremagic){
 345     moremagic = mg->mg_moremagic;
 346     if (mg->mg_type == PERL_MAGIC_uvar) { break; }
 347    }
 348    /* assert(mg); */
 349    uf = (struct ufuncs *) mg->mg_ptr;
 350    /* assert(uf->uf_val == vmg_svt_val); */
 351    if (uf[1].uf_val || uf[1].uf_set) {
 352     /* Revert the original uvar magic. */
 353     uf[0] = uf[1];
 354     Renew(uf, 1, struct ufuncs);
 355     mg->mg_len = sizeof(struct ufuncs);
 356    } else {
 357     /* Remove the uvar magic. */
 358     vmg_uvar_del(sv, prevmagic, mg, moremagic);
 359    }
 360   }
 361  }
 362 #endif /* VMG_UVAR */
 363
 364  return 1;
 365 }
 366
 367 /* ... svt callbacks ....................................................... */
 368
 369 STATIC int vmg_cb_call(pTHX_ SV *cb, SV *sv, SV *data) {
 370 #define vmg_cb_call(I, S, D) vmg_cb_call(aTHX_ (I), (S), (D))
 371  int ret;
 372
 373  dSP;
 374  int count;
 375
 376  ENTER;
 377  SAVETMPS;
 378
 379  PUSHMARK(SP);
 380  XPUSHs(sv_2mortal(newRV_inc(sv)));
 381  if (data) { XPUSHs(data); }
 382  PUTBACK;
 383
 384  count = call_sv(cb, G_SCALAR);
 385
 386  SPAGAIN;
 387
 388  if (count != 1) { croak("Callback needs to return 1 scalar\n"); }
 389  ret = POPi;
 390
 391  PUTBACK;
 392
 393  FREETMPS;
 394  LEAVE;
 395
 396  return ret;
 397 }
 398
 399 #if MGf_COPY || VMG_UVAR
 400 STATIC int vmg_cb_call2(pTHX_ SV *cb, SV *sv, SV *data, SV *sv2) {
 401 #define vmg_cb_call2(I, S, D, S2) vmg_cb_call2(aTHX_ (I), (S), (D), (S2))
 402  int ret;
 403
 404  dSP;
 405  int count;
 406
 407  ENTER;
 408  SAVETMPS;
 409
 410  PUSHMARK(SP);
 411  XPUSHs(sv_2mortal(newRV_inc(sv)));
 412  XPUSHs(data ? data : &PL_sv_undef);
 413  if (sv2) { XPUSHs(sv2); }
 414  PUTBACK;
 415
 416  count = call_sv(cb, G_SCALAR);
 417
 418  SPAGAIN;
 419
 420  if (count != 1) { croak("Callback needs to return 1 scalar\n"); }
 421  ret = POPi;
 422
 423  PUTBACK;
 424
 425  FREETMPS;
 426  LEAVE;
 427
 428  return ret;
 429 }
 430 #endif /* MGf_COPY || VMG_UVAR */
 431
 432 STATIC int vmg_svt_get(pTHX_ SV *sv, MAGIC *mg) {
 433  return vmg_cb_call(SV2MGWIZ(mg->mg_ptr)->cb_get, sv, mg->mg_obj);
 434 }
 435
 436 STATIC int vmg_svt_set(pTHX_ SV *sv, MAGIC *mg) {
 437  return vmg_cb_call(SV2MGWIZ(mg->mg_ptr)->cb_set, sv, mg->mg_obj);
 438 }
 439
 440 STATIC U32 vmg_svt_len(pTHX_ SV *sv, MAGIC *mg) {
 441  U32 ret;
 442
 443  dSP;
 444  int count;
 445
 446  ENTER;
 447  SAVETMPS;
 448
 449  PUSHMARK(SP);
 450  XPUSHs(sv_2mortal(newRV_inc(sv)));
 451  XPUSHs(mg->mg_obj ? mg->mg_obj : &PL_sv_undef);
 452  if (SvTYPE(sv) == SVt_PVAV) {
 453   XPUSHs(sv_2mortal(newSViv(av_len((AV *) sv) + 1)));
 454  }
 455  PUTBACK;
 456
 457  count = call_sv(SV2MGWIZ(mg->mg_ptr)->cb_len, G_SCALAR);
 458
 459  SPAGAIN;
 460
 461  if (count != 1) { croak("Callback needs to return 1 scalar\n"); }
 462  ret = POPi;
 463
 464  PUTBACK;
 465
 466  FREETMPS;
 467  LEAVE;
 468
 469  return ret - 1;
 470 }
 471
 472 STATIC int vmg_svt_clear(pTHX_ SV *sv, MAGIC *mg) {
 473  return vmg_cb_call(SV2MGWIZ(mg->mg_ptr)->cb_clear, sv, mg->mg_obj);
 474 }
 475
 476 STATIC int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) {
 477  /* So that it can survive tmp cleanup in vmg_cb_call */
 478  SvREFCNT_inc(sv);
 479  /* Perl_mg_free will get rid of the magic and decrement mg->mg_obj and
 480   * mg->mg_ptr reference count */
 481  return vmg_cb_call(SV2MGWIZ(mg->mg_ptr)->cb_free, sv, mg->mg_obj);
 482 }
 483
 484 #if MGf_COPY
 485 STATIC int vmg_svt_copy(pTHX_ SV *sv, MAGIC *mg, SV *nsv, const char *name, int namelen) {
 486  return vmg_cb_call2(SV2MGWIZ(mg->mg_ptr)->cb_copy, sv, mg->mg_obj, nsv);
 487 }
 488 #endif /* MGf_COPY */
 489
 490 #if MGf_DUP
 491 STATIC int vmg_svt_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) {
 492  return 0;
 493 }
 494 #endif /* MGf_DUP */
 495
 496 #if MGf_LOCAL
 497 STATIC int vmg_svt_local(pTHX_ SV *nsv, MAGIC *mg) {
 498  return vmg_cb_call(SV2MGWIZ(mg->mg_ptr)->cb_local, nsv, mg->mg_obj);
 499 }
 500 #endif /* MGf_LOCAL */
 501
 502 #if VMG_UVAR
 503 STATIC I32 vmg_svt_val(pTHX_ IV action, SV *sv) {
 504  struct ufuncs *uf;
 505  MAGIC *mg;
 506  SV *key = NULL;
 507
 508  mg  = mg_find(sv, PERL_MAGIC_uvar);
 509  /* mg can't be NULL or we wouldn't be there. */
 510  key = mg->mg_obj;
 511  uf  = (struct ufuncs *) mg->mg_ptr;
 512
 513  if (uf[1].uf_val != NULL) { uf[1].uf_val(aTHX_ action, sv); }
 514  if (uf[1].uf_set != NULL) { uf[1].uf_set(aTHX_ action, sv); }
 515
 516  action &= HV_FETCH_ISSTORE | HV_FETCH_ISEXISTS | HV_FETCH_LVALUE | HV_DELETE;
 517  for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 518   MGWIZ *w;
 519   if ((mg->mg_type != PERL_MAGIC_ext)
 520    || (mg->mg_private < SIG_MIN)
 521    || (mg->mg_private > SIG_MAX)) { continue; }
 522   w = SV2MGWIZ(mg->mg_ptr);
 523   switch (action) {
 524    case 0:
 525     vmg_cb_call2(w->cb_fetch, sv, mg->mg_obj, key);
 526     break;
 527    case HV_FETCH_ISSTORE:
 528    case HV_FETCH_LVALUE:
 529    case (HV_FETCH_ISSTORE|HV_FETCH_LVALUE):
 530     vmg_cb_call2(w->cb_store, sv, mg->mg_obj, key);
 531     break;
 532    case HV_FETCH_ISEXISTS:
 533     vmg_cb_call2(w->cb_exists, sv, mg->mg_obj, key);
 534     break;
 535    case HV_DELETE:
 536     vmg_cb_call2(w->cb_delete, sv, mg->mg_obj, key);
 537     break;
 538   }
 539  }
 540
 541  return 0;
 542 }
 543 #endif /* VMG_UVAR */
 544
 545 /* ... Wizard destructor ................................................... */
 546
 547 STATIC int vmg_wizard_free(pTHX_ SV *wiz, MAGIC *mg) {
 548  char buf[8];
 549  MGWIZ *w;
 550  dMY_CXT;
 551
 552  w = SV2MGWIZ(wiz);
 553
 554  SvREFCNT_inc(wiz); /* Fake survival - it's gonna be deleted anyway */
 555 #if PERL_API_VERSION_GE(5, 9, 5)
 556  SvREFCNT_inc(wiz); /* One more push */
 557 #endif
 558  if (hv_delete(MY_CXT.wizz, buf, sprintf(buf, "%u", w->sig), 0)) {
 559   --MY_CXT.count;
 560  }
 561
 562  if (w->cb_data  != NULL) { SvREFCNT_dec(SvRV(w->cb_data)); }
 563  if (w->cb_get   != NULL) { SvREFCNT_dec(SvRV(w->cb_get)); }
 564  if (w->cb_set   != NULL) { SvREFCNT_dec(SvRV(w->cb_set)); }
 565  if (w->cb_len   != NULL) { SvREFCNT_dec(SvRV(w->cb_len)); }
 566  if (w->cb_clear != NULL) { SvREFCNT_dec(SvRV(w->cb_clear)); }
 567  if (w->cb_free  != NULL) { SvREFCNT_dec(SvRV(w->cb_free)); }
 568 #if MGf_COPY
 569  if (w->cb_copy  != NULL) { SvREFCNT_dec(SvRV(w->cb_copy)); }
 570 #endif /* MGf_COPY */
 571 #if MGf_DUP
 572  if (w->cb_dup   != NULL) { SvREFCNT_dec(SvRV(w->cb_dup)); }
 573 #endif /* MGf_COPY */
 574 #if MGf_LOCAL
 575  if (w->cb_local != NULL) { SvREFCNT_dec(SvRV(w->cb_local)); }
 576 #endif /* MGf_COPY */
 577 #if VMG_UVAR
 578  if (w->cb_fetch  != NULL) { SvREFCNT_dec(SvRV(w->cb_fetch)); }
 579  if (w->cb_store  != NULL) { SvREFCNT_dec(SvRV(w->cb_store)); }
 580  if (w->cb_exists != NULL) { SvREFCNT_dec(SvRV(w->cb_exists)); }
 581  if (w->cb_delete != NULL) { SvREFCNT_dec(SvRV(w->cb_delete)); }
 582 #endif /* VMG_UVAR */
 583  Safefree(w->vtbl);
 584  Safefree(w);
 585
 586  return 0;
 587 }
 588
 589 STATIC MGVTBL vmg_wizard_vtbl = {
 590  NULL,            /* get */
 591  NULL,            /* set */
 592  NULL,            /* len */
 593  NULL,            /* clear */
 594  vmg_wizard_free, /* free */
 595 #if MGf_COPY
 596  NULL,            /* copy */
 597 #endif /* MGf_COPY */
 598 #if MGf_DUP
 599  NULL,            /* dup */
 600 #endif /* MGf_DUP */
 601 #if MGf_LOCAL
 602  NULL,            /* local */
 603 #endif /* MGf_DUP */
 604 };
 605
 606 STATIC const char vmg_invalid_wiz[]    = "Invalid wizard object";
 607 STATIC const char vmg_invalid_sv[]     = "Invalid variable";
 608 STATIC const char vmg_invalid_sig[]    = "Invalid numeric signature";
 609 STATIC const char vmg_wrongargnum[]    = "Wrong number of arguments";
 610 STATIC const char vmg_toomanysigs[]    = "Too many magic signatures used";
 611 STATIC const char vmg_argstorefailed[] = "Error while storing arguments";
 612
 613 STATIC U16 vmg_sv2sig(pTHX_ SV *sv) {
 614 #define vmg_sv2sig(S) vmg_sv2sig(aTHX_ (S))
 615  U16 sig;
 616
 617  if (SvIOK(sv)) {
 618   sig = SvUVX(sv);
 619  } else if (SvNOK(sv)) {
 620   sig = SvNVX(sv);
 621  } else if ((SvPOK(sv) && grok_number(SvPVX(sv), SvCUR(sv), NULL))) {
 622   sig = SvUV(sv);
 623  } else {
 624   croak(vmg_invalid_sig);
 625  }
 626  if (sig < SIG_MIN) { sig += SIG_MIN; }
 627  if (sig > SIG_MAX) { sig %= SIG_MAX + 1; }
 628
 629  return sig;
 630 }
 631
 632 #define VMG_SET_CB(S, N)              \
 633  cb = (S);                            \
 634  w->cb_ ## N = (SvOK(cb) && SvROK(cb)) ? newRV_inc(SvRV(cb)) : NULL;
 635
 636 #define VMG_SET_SVT_CB(S, N)          \
 637  cb = (S);                            \
 638  if (SvOK(cb) && SvROK(cb)) {         \
 639   t->svt_ ## N = vmg_svt_ ## N;       \
 640   w->cb_  ## N = newRV_inc(SvRV(cb)); \
 641  } else {                             \
 642   t->svt_ ## N = NULL;                \
 643   w->cb_  ## N = NULL;                \
 644  }
 645
 646
 647 /* --- XS ------------------------------------------------------------------ */
 648
 649 MODULE = Variable::Magic            PACKAGE = Variable::Magic
 650
 651 PROTOTYPES: ENABLE
 652
 653 BOOT:
 654 {
 655  HV *stash;
 656  MY_CXT_INIT;
 657  MY_CXT.wizz = newHV();
 658  MY_CXT.count = 0;
 659  stash = gv_stashpv(__PACKAGE__, 1);
 660  newCONSTSUB(stash, "SIG_MIN",   newSVuv(SIG_MIN));
 661  newCONSTSUB(stash, "SIG_MAX",   newSVuv(SIG_MAX));
 662  newCONSTSUB(stash, "SIG_NBR",   newSVuv(SIG_NBR));
 663  newCONSTSUB(stash, "MGf_COPY",  newSVuv(MGf_COPY));
 664  newCONSTSUB(stash, "MGf_DUP",   newSVuv(MGf_DUP));
 665  newCONSTSUB(stash, "MGf_LOCAL", newSVuv(MGf_LOCAL));
 666  newCONSTSUB(stash, "VMG_UVAR",  newSVuv(VMG_UVAR));
 667 }
 668
 669 SV *_wizard(...)
 670 PROTOTYPE: DISABLE
 671 PREINIT:
 672  I32 i = 0;
 673  U16 sig;
 674  char buf[8];
 675  MGWIZ *w;
 676  MGVTBL *t;
 677  MAGIC *mg;
 678  SV *sv;
 679  SV *svsig;
 680  SV *cb;
 681 CODE:
 682  dMY_CXT;
 683
 684  if (items != 7
 685 #if MGf_COPY
 686               + 1
 687 #endif /* MGf_COPY */
 688 #if MGf_DUP
 689               + 1
 690 #endif /* MGf_DUP */
 691 #if MGf_LOCAL
 692               + 1
 693 #endif /* MGf_LOCAL */
 694 #if VMG_UVAR
 695               + 4
 696 #endif /* VMG_UVAR */
 697               ) { croak(vmg_wrongargnum); }
 698
 699  svsig = ST(i++);
 700  if (SvOK(svsig)) {
 701   SV **old;
 702   sig = vmg_sv2sig(svsig);
 703   if (old = hv_fetch(MY_CXT.wizz, buf, sprintf(buf, "%u", sig), 0)) {
 704    ST(0) = sv_2mortal(newRV_inc(*old));
 705    XSRETURN(1);
 706   }
 707  } else {
 708   if (MY_CXT.count >= SIG_NBR) { croak(vmg_toomanysigs); }
 709   sig = vmg_gensig();
 710  }
 711
 712  Newx(t, 1, MGVTBL);
 713  Newx(w, 1, MGWIZ);
 714
 715  VMG_SET_CB(ST(i++), data);
 716  VMG_SET_SVT_CB(ST(i++), get);
 717  VMG_SET_SVT_CB(ST(i++), set);
 718  VMG_SET_SVT_CB(ST(i++), len);
 719  VMG_SET_SVT_CB(ST(i++), clear);
 720  VMG_SET_SVT_CB(ST(i++), free);
 721 #if MGf_COPY
 722  VMG_SET_SVT_CB(ST(i++), copy);
 723 #endif /* MGf_COPY */
 724 #if MGf_DUP
 725  VMG_SET_SVT_CB(ST(i++), dup);
 726 #endif /* MGf_DUP */
 727 #if MGf_LOCAL
 728  VMG_SET_SVT_CB(ST(i++), local);
 729 #endif /* MGf_LOCAL */
 730 #if VMG_UVAR
 731  VMG_SET_CB(ST(i++), fetch);
 732  VMG_SET_CB(ST(i++), store);
 733  VMG_SET_CB(ST(i++), exists);
 734  VMG_SET_CB(ST(i++), delete);
 735 #endif /* VMG_UVAR */
 736
 737  w->vtbl = t;
 738  w->sig  = sig;
 739 #if VMG_UVAR
 740  w->uvar = (w->cb_fetch || w->cb_store || w->cb_exists || w->cb_delete);
 741 #endif /* VMG_UVAR */
 742
 743  sv = MGWIZ2SV(w);
 744  mg = sv_magicext(sv, NULL, PERL_MAGIC_ext, &vmg_wizard_vtbl, NULL, -1);
 745  mg->mg_private = SIG_WIZ;
 746
 747  hv_store(MY_CXT.wizz, buf, sprintf(buf, "%u", sig), sv, 0);
 748  ++MY_CXT.count;
 749
 750  RETVAL = newRV_noinc(sv);
 751 OUTPUT:
 752  RETVAL
 753
 754 SV *gensig()
 755 PROTOTYPE:
 756 CODE:
 757  dMY_CXT;
 758  if (MY_CXT.count >= SIG_NBR) { croak(vmg_toomanysigs); }
 759  RETVAL = newSVuv(vmg_gensig());
 760 OUTPUT:
 761  RETVAL
 762
 763 SV *getsig(SV *wiz)
 764 PROTOTYPE: $
 765 CODE:
 766  if (!SvROK(wiz)) { croak(vmg_invalid_wiz); }
 767  RETVAL = newSVuv(SV2MGWIZ(SvRV(wiz))->sig);
 768 OUTPUT:
 769  RETVAL
 770
 771 SV *cast(SV *sv, SV *wiz, ...)
 772 PROTOTYPE: \[$@%&*]$@
 773 PREINIT:
 774  AV *args = NULL;
 775  SV *ret;
 776 CODE:
 777  dMY_CXT;
 778  if (SvROK(wiz)) {
 779   wiz = SvRV(wiz);
 780  } else if (SvOK(wiz)) {
 781   char buf[8];
 782   SV **old;
 783   U16 sig = vmg_sv2sig(wiz);
 784   if (old = hv_fetch(MY_CXT.wizz, buf, sprintf(buf, "%u", sig), 0)) {
 785    wiz = *old;
 786   } else {
 787    XSRETURN_UNDEF;
 788   }
 789  } else {
 790   croak(vmg_invalid_sig);
 791  }
 792  if (items > 2) {
 793   I32 i;
 794   args = newAV();
 795   av_fill(args, items - 2);
 796   for (i = 2; i < items; ++i) {
 797    SV *arg = ST(i);
 798    SvREFCNT_inc(arg);
 799    if (av_store(args, i - 2, arg) == NULL) { croak(vmg_argstorefailed); }
 800   }
 801  }
 802  ret = newSVuv(vmg_cast(SvRV(sv), wiz, args));
 803  SvREFCNT_dec(args);
 804  RETVAL = ret;
 805 OUTPUT:
 806  RETVAL
 807
 808 SV *getdata(SV *sv, SV *wiz)
 809 PROTOTYPE: \[$@%&*]$
 810 PREINIT:
 811  SV *data;
 812  U16 sig;
 813 CODE:
 814  dMY_CXT;
 815  if (SvROK(wiz)) {
 816   sig = SV2MGWIZ(SvRV(wiz))->sig;
 817  } else if (SvOK(wiz)) {
 818   char buf[8];
 819   sig = vmg_sv2sig(wiz);
 820   if (!hv_fetch(MY_CXT.wizz, buf, sprintf(buf, "%u", sig), 0)) {
 821    XSRETURN_UNDEF;
 822   }
 823  } else {
 824   croak(vmg_invalid_wiz);
 825  }
 826  data = vmg_data_get(SvRV(sv), sig);
 827  if (!data) { XSRETURN_UNDEF; }
 828  ST(0) = data;
 829  XSRETURN(1);
 830
 831 SV *dispell(SV *sv, SV *wiz)
 832 PROTOTYPE: \[$@%&*]$
 833 PREINIT:
 834  U16 sig;
 835 CODE:
 836  dMY_CXT;
 837  if (SvROK(wiz)) {
 838   sig = SV2MGWIZ(SvRV(wiz))->sig;
 839  } else if (SvOK(wiz)) {
 840   char buf[8];
 841   sig = vmg_sv2sig(wiz);
 842   if (!hv_fetch(MY_CXT.wizz, buf, sprintf(buf, "%u", sig), 0)) {
 843    XSRETURN_UNDEF;
 844   }
 845  } else {
 846   croak(vmg_invalid_wiz);
 847  }
 848  RETVAL = newSVuv(vmg_dispell(SvRV(sv), sig));
 849 OUTPUT:
 850  RETVAL