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 /* --- Our sv_magicext ----------------------------------------------------- */
  41
  42 #ifdef sv_magicext
  43 STATIC MAGIC *vmg_sv_magicext(pTHX_ SV *sv, SV *obj, MGVTBL *vtbl, SV *obj2, I32 flag) {
  44  return sv_magicext(sv, obj, PERL_MAGIC_ext, vtbl, (const char *) obj2, flag);
  45 }
  46 #else /* Stub inspired from 5.7.3's sv_magicext */
  47 STATIC MAGIC *vmg_sv_magicext(pTHX_ SV *sv, SV *obj, MGVTBL *vtbl, SV *obj2, I32 flag) {
  48  MAGIC* mg;
  49
  50  if (SvTYPE(sv) < SVt_PVMG) {
  51   SvUPGRADE(sv, SVt_PVMG);
  52  }
  53  Newx(mg, 1, MAGIC);
  54  mg->mg_moremagic = SvMAGIC(sv);
  55  SvMAGIC_set(sv, mg);
  56
  57  if (!obj || obj == sv ||
  58      (SvTYPE(obj) == SVt_PVGV &&
  59         (GvSV(obj) == sv || GvHV(obj) == (HV *) sv || GvAV(obj) == (AV *) sv ||
  60                             GvCV(obj) == (CV *) sv || GvIOp(obj) == (IO *) sv ||
  61                             GvFORM(obj) == (CV *) sv))) {
  62   mg->mg_obj = obj;
  63  } else {
  64   mg->mg_obj = SvREFCNT_inc(obj);
  65   mg->mg_flags |= MGf_REFCOUNTED;
  66  }
  67
  68  mg->mg_type = PERL_MAGIC_ext;
  69  mg->mg_len  = flag;
  70  if (obj2) {
  71   if (flag == HEf_SVKEY) {
  72    mg->mg_ptr = (char *) SvREFCNT_inc((SV *) obj2);
  73   } else {
  74    mg->mg_ptr = (char *) obj2;
  75   }
  76  }
  77  mg->mg_virtual = vtbl;
  78
  79  mg_magical(sv);
  80  if (SvGMAGICAL(sv)) {
  81   SvFLAGS(sv) &= ~(SVf_IOK | SVf_NOK | SVf_POK);
  82  }
  83
  84  return mg;
  85 }
  86 #endif
  87 #define vmg_sv_magicext(S, O, V, OO, F) vmg_sv_magicext(aTHX_ (S), (O), (V), (OO), (F))
  88
  89 /* --- Context-safe global data -------------------------------------------- */
  90
  91 #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
  92
  93 typedef struct {
  94  HV *wizz;
  95  U16 count;
  96 } my_cxt_t;
  97
  98 START_MY_CXT
  99
 100 /* --- Signatures ---------------------------------------------------------- */
 101
 102 #define SIG_MIN ((U16) (1u << 8))
 103 #define SIG_MAX ((U16) (1u << 16 - 1))
 104 #define SIG_NBR (SIG_MAX - SIG_MIN + 1)
 105 #define SIG_WIZ ((U16) (1u << 8 - 1))
 106
 107 /* ... Generate signatures ................................................. */
 108
 109 STATIC U16 vmg_gensig(pTHX) {
 110 #define vmg_gensig() vmg_gensig(aTHX)
 111  U16 sig;
 112  char buf[8];
 113  dMY_CXT;
 114
 115  do {
 116   sig = SIG_NBR * Drand01() + SIG_MIN;
 117  } while (hv_exists(MY_CXT.wizz, buf, sprintf(buf, "%u", sig)));
 118
 119  return sig;
 120 }
 121
 122 /* --- MGWIZ structure ----------------------------------------------------- */
 123
 124 typedef struct {
 125  MGVTBL *vtbl;
 126  U16 sig;
 127  SV *cb_get, *cb_set, *cb_len, *cb_clear, *cb_free, *cb_data;
 128 } MGWIZ;
 129
 130 #define MGWIZ2SV(W) (newSVuv(PTR2UV(W)))
 131 #define SV2MGWIZ(S) (INT2PTR(MGWIZ*, SvUVX((SV *) (S))))
 132
 133 /* ... Construct private data .............................................. */
 134
 135 STATIC SV *vmg_data_new(pTHX_ SV *ctor, SV *sv, AV *args) {
 136 #define vmg_data_new(C, S, A) vmg_data_new(aTHX_ (C), (S), (A))
 137  SV *nsv;
 138
 139  dSP;
 140  int count;
 141
 142  ENTER;
 143  SAVETMPS;
 144
 145  PUSHMARK(SP);
 146  XPUSHs(sv_2mortal(newRV_inc(sv)));
 147  if (args != NULL) {
 148   I32 i, alen = av_len(args);
 149   for (i = 0; i < alen; ++i) { XPUSHs(*av_fetch(args, i, 0)); }
 150  }
 151  PUTBACK;
 152
 153  count = call_sv(ctor, G_SCALAR);
 154
 155  SPAGAIN;
 156
 157  if (count != 1) { croak("Callback needs to return 1 scalar\n"); }
 158  nsv = POPs;
 159 #if PERL_VERSION_LE(5, 8, 2)
 160  nsv = sv_newref(nsv); /* Workaround some bug in SvREFCNT_inc() */
 161 #else
 162  SvREFCNT_inc(nsv);    /* Or it will be destroyed in FREETMPS */
 163 #endif
 164
 165  PUTBACK;
 166
 167  FREETMPS;
 168  LEAVE;
 169
 170  return nsv;
 171 }
 172
 173 STATIC SV *vmg_data_get(SV *sv, U16 sig) {
 174  MAGIC *mg, *moremagic;
 175  MGWIZ *w;
 176
 177  if (SvTYPE(sv) >= SVt_PVMG) {
 178   for (mg = SvMAGIC(sv); mg; mg = moremagic) {
 179    moremagic = mg->mg_moremagic;
 180    if ((mg->mg_type == PERL_MAGIC_ext) && (mg->mg_private == sig)) { break; }
 181   }
 182   if (mg) { return mg->mg_obj; }
 183  }
 184
 185  return NULL;
 186 }
 187
 188 /* ... Magic cast/dispell .................................................. */
 189
 190 STATIC UV vmg_cast(pTHX_ SV *sv, SV *wiz, AV *args) {
 191 #define vmg_cast(S, W, A) vmg_cast(aTHX_ (S), (W), (A))
 192  MAGIC *mg = NULL, *moremagic = NULL;
 193  MGWIZ *w;
 194  SV *data;
 195
 196  w = SV2MGWIZ(wiz);
 197
 198  if (SvTYPE(sv) >= SVt_PVMG) {
 199   for (mg = SvMAGIC(sv); mg; mg = moremagic) {
 200    moremagic = mg->mg_moremagic;
 201    if ((mg->mg_type == PERL_MAGIC_ext) && (mg->mg_private == w->sig)) { break; }
 202   }
 203   if (mg) { return 1; }
 204  }
 205
 206  data = (w->cb_data) ? vmg_data_new(w->cb_data, sv, args) : NULL;
 207  mg = vmg_sv_magicext(sv, data, w->vtbl, wiz, HEf_SVKEY);
 208  mg->mg_private = w->sig;
 209
 210  return 1;
 211 }
 212
 213 STATIC UV vmg_dispell(pTHX_ SV *sv, U16 sig) {
 214 #define vmg_dispell(S, Z) vmg_dispell(aTHX_ (S), (Z))
 215  MAGIC *mg, *prevmagic, *moremagic = NULL;
 216  MGWIZ *w;
 217
 218  if (SvTYPE(sv) < SVt_PVMG) { return 0; }
 219
 220  for (prevmagic = NULL, mg = SvMAGIC(sv); mg; prevmagic = mg, mg = moremagic) {
 221   moremagic = mg->mg_moremagic;
 222   if ((mg->mg_type == PERL_MAGIC_ext) && (mg->mg_private == sig)) { break; }
 223  }
 224  if (!mg) { return 0; }
 225
 226  if (prevmagic) {
 227   prevmagic->mg_moremagic = moremagic;
 228  } else {
 229   SvMAGIC_set(sv, moremagic);
 230  }
 231  mg->mg_moremagic = NULL;
 232
 233  if (mg->mg_obj != sv) { SvREFCNT_dec(mg->mg_obj); } /* Destroy private data */
 234  SvREFCNT_dec((SV *) mg->mg_ptr); /* Unreference the wizard */
 235  Safefree(mg);
 236
 237  return 1;
 238 }
 239
 240 /* ... svt callbacks ....................................................... */
 241
 242 STATIC int vmg_cb_call(pTHX_ SV *cb, SV *sv, SV *data) {
 243 #define vmg_cb_call(I, S, D) vmg_cb_call(aTHX_ (I), (S), (D))
 244  int ret;
 245
 246  dSP;
 247  int count;
 248
 249  ENTER;
 250  SAVETMPS;
 251
 252  PUSHMARK(SP);
 253  XPUSHs(sv_2mortal(newRV_inc(sv)));
 254  if (data) { XPUSHs(data); }
 255  PUTBACK;
 256
 257  count = call_sv(cb, G_SCALAR);
 258
 259  SPAGAIN;
 260
 261  if (count != 1) { croak("Callback needs to return 1 scalar\n"); }
 262  ret = POPi;
 263
 264  PUTBACK;
 265
 266  FREETMPS;
 267  LEAVE;
 268
 269  return ret;
 270 }
 271
 272 STATIC int vmg_svt_get(pTHX_ SV *sv, MAGIC *mg) {
 273  return vmg_cb_call(SV2MGWIZ(mg->mg_ptr)->cb_get, sv, mg->mg_obj);
 274 }
 275
 276 STATIC int vmg_svt_set(pTHX_ SV *sv, MAGIC *mg) {
 277  return vmg_cb_call(SV2MGWIZ(mg->mg_ptr)->cb_set, sv, mg->mg_obj);
 278 }
 279
 280 STATIC U32 vmg_svt_len(pTHX_ SV *sv, MAGIC *mg) {
 281  U32 ret;
 282
 283  dSP;
 284  int count;
 285
 286  ENTER;
 287  SAVETMPS;
 288
 289  PUSHMARK(SP);
 290  XPUSHs(sv_2mortal(newRV_inc(sv)));
 291  XPUSHs((mg->mg_obj) ? (mg->mg_obj) : &PL_sv_undef);
 292  if (SvTYPE(sv) == SVt_PVAV) {
 293   XPUSHs(sv_2mortal(newSViv(av_len((AV *) sv) + 1)));
 294  }
 295  PUTBACK;
 296
 297  count = call_sv(SV2MGWIZ(mg->mg_ptr)->cb_len, G_SCALAR);
 298
 299  SPAGAIN;
 300
 301  if (count != 1) { croak("Callback needs to return 1 scalar\n"); }
 302  ret = POPi;
 303
 304  PUTBACK;
 305
 306  FREETMPS;
 307  LEAVE;
 308
 309  return ret - 1;
 310 }
 311
 312 STATIC int vmg_svt_clear(pTHX_ SV *sv, MAGIC *mg) {
 313  return vmg_cb_call(SV2MGWIZ(mg->mg_ptr)->cb_clear, sv, mg->mg_obj);
 314 }
 315
 316 STATIC int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) {
 317  /* So that it can survive tmp cleanup in vmg_cb_call */
 318  SvREFCNT_inc(sv);
 319  /* Perl_mg_free will get rid of the magic and decrement mg->mg_obj and
 320   * mg->mg_ptr reference count */
 321  return vmg_cb_call(SV2MGWIZ(mg->mg_ptr)->cb_free, sv, mg->mg_obj);
 322 }
 323
 324 /* ... Wizard destructor ................................................... */
 325
 326 STATIC int vmg_wizard_free(pTHX_ SV *wiz, MAGIC *mg) {
 327  char buf[8];
 328  MGWIZ *w;
 329  dMY_CXT;
 330
 331  w = SV2MGWIZ(wiz);
 332
 333  SvREFCNT_inc(wiz); /* Fake survival - it's gonna be deleted anyway */
 334 #if PERL_API_VERSION_GE(5, 9, 5)
 335  SvREFCNT_inc(wiz); /* One more push */
 336 #endif
 337  if (hv_delete(MY_CXT.wizz, buf, sprintf(buf, "%u", w->sig), 0)) {
 338   --MY_CXT.count;
 339  }
 340
 341  if (w->cb_get   != NULL) { SvREFCNT_dec(SvRV(w->cb_get)); }
 342  if (w->cb_set   != NULL) { SvREFCNT_dec(SvRV(w->cb_set)); }
 343  if (w->cb_len   != NULL) { SvREFCNT_dec(SvRV(w->cb_len)); }
 344  if (w->cb_clear != NULL) { SvREFCNT_dec(SvRV(w->cb_clear)); }
 345  if (w->cb_free  != NULL) { SvREFCNT_dec(SvRV(w->cb_free)); }
 346  if (w->cb_data  != NULL) { SvREFCNT_dec(SvRV(w->cb_data)); }
 347  Safefree(w->vtbl);
 348  Safefree(w);
 349
 350  return 0;
 351 }
 352
 353 STATIC MGVTBL vmg_wizard_vtbl = {
 354  NULL,            /* get */
 355  NULL,            /* set */
 356  NULL,            /* len */
 357  NULL,            /* clear */
 358  vmg_wizard_free, /* free */
 359 #ifdef MGf_COPY
 360  NULL,            /* copy */
 361 #endif /* MGf_COPY */
 362 #ifdef MGf_DUP
 363  NULL,            /* dup */
 364 #endif /* MGf_DUP */
 365 };
 366
 367 STATIC const char vmg_invalid_wiz[]    = "Invalid wizard object";
 368 STATIC const char vmg_invalid_sv[]     = "Invalid variable";
 369 STATIC const char vmg_invalid_sig[]    = "Invalid numeric signature";
 370 STATIC const char vmg_toomanysigs[]    = "Too many magic signatures used";
 371 STATIC const char vmg_argstorefailed[] = "Error while storing arguments";
 372
 373 STATIC U16 vmg_sv2sig(pTHX_ SV *sv) {
 374 #define vmg_sv2sig(S) vmg_sv2sig(aTHX_ (S))
 375  U16 sig;
 376
 377  if (SvIOK(sv)) {
 378   sig = SvUVX(sv);
 379  } else if (SvNOK(sv)) {
 380   sig = SvNVX(sv);
 381  } else if ((SvPOK(sv) && grok_number(SvPVX(sv), SvCUR(sv), NULL))) {
 382   sig = SvUV(sv);
 383  } else {
 384   croak(vmg_invalid_sig);
 385  }
 386  if (sig < SIG_MIN) { sig += SIG_MIN; }
 387  if (sig > SIG_MAX) { sig %= SIG_MAX + 1; }
 388
 389  return sig;
 390 }
 391
 392 /* --- XS ------------------------------------------------------------------ */
 393
 394 MODULE = Variable::Magic            PACKAGE = Variable::Magic
 395
 396 PROTOTYPES: ENABLE
 397
 398 BOOT:
 399 {
 400  HV *stash;
 401  MY_CXT_INIT;
 402  MY_CXT.wizz = newHV();
 403  MY_CXT.count = 0;
 404  stash = gv_stashpv(__PACKAGE__, 1);
 405  newCONSTSUB(stash, "SIG_MIN",  newSVuv(SIG_MIN));
 406  newCONSTSUB(stash, "SIG_MAX",  newSVuv(SIG_MAX));
 407  newCONSTSUB(stash, "SIG_NBR",  newSVuv(SIG_NBR));
 408 /*
 409  newCONSTSUB(stash, "MGf_COPY", newSVuv(MGf_COPY));
 410  newCONSTSUB(stash, "MGf_DUP",  newSVuv(MGf_DUP));
 411 */
 412 }
 413
 414 SV *_wizard(SV *svsig, SV *cb_get, SV *cb_set, SV *cb_len, SV *cb_clear, SV *cb_free, SV *cb_data)
 415 PROTOTYPE: $&&&&&&
 416 PREINIT:
 417  U16 sig;
 418  char buf[8];
 419  MGWIZ *w;
 420  MGVTBL *t;
 421  MAGIC *mg;
 422  SV *sv;
 423 CODE:
 424  dMY_CXT;
 425  if (SvOK(svsig)) {
 426   SV **old;
 427   sig = vmg_sv2sig(svsig);
 428   if (old = hv_fetch(MY_CXT.wizz, buf, sprintf(buf, "%u", sig), 0)) {
 429    ST(0) = sv_2mortal(newRV_inc(*old));
 430    XSRETURN(1);
 431   }
 432  } else {
 433   if (MY_CXT.count >= SIG_NBR) { croak(vmg_toomanysigs); }
 434   sig = vmg_gensig();
 435  }
 436
 437  Newx(t, 1, MGVTBL);
 438  t->svt_get   = (SvOK(cb_get))   ? vmg_svt_get   : NULL;
 439  t->svt_set   = (SvOK(cb_set))   ? vmg_svt_set   : NULL;
 440  t->svt_len   = (SvOK(cb_len))   ? vmg_svt_len   : NULL;
 441  t->svt_clear = (SvOK(cb_clear)) ? vmg_svt_clear : NULL;
 442  t->svt_free  = (SvOK(cb_free))  ? vmg_svt_free  : NULL;
 443 #ifdef MGf_COPY
 444  t->svt_copy  = NULL;
 445 #endif /* MGf_COPY */
 446 #ifdef MGf_DUP
 447  t->svt_dup   = NULL;
 448 #endif /* MGf_DUP */
 449
 450  Newx(w, 1, MGWIZ);
 451  w->vtbl = t;
 452  w->sig  = sig;
 453  w->cb_get   = (SvROK(cb_get))   ? newRV_inc(SvRV(cb_get))   : NULL;
 454  w->cb_set   = (SvROK(cb_set))   ? newRV_inc(SvRV(cb_set))   : NULL;
 455  w->cb_len   = (SvROK(cb_len))   ? newRV_inc(SvRV(cb_len))   : NULL;
 456  w->cb_clear = (SvROK(cb_clear)) ? newRV_inc(SvRV(cb_clear)) : NULL;
 457  w->cb_free  = (SvROK(cb_free))  ? newRV_inc(SvRV(cb_free))  : NULL;
 458  w->cb_data  = (SvROK(cb_data))  ? newRV_inc(SvRV(cb_data))  : NULL;
 459
 460  sv = MGWIZ2SV(w);
 461  mg = vmg_sv_magicext(sv, NULL, &vmg_wizard_vtbl, NULL, -1);
 462  mg->mg_private = SIG_WIZ;
 463
 464  hv_store(MY_CXT.wizz, buf, sprintf(buf, "%u", sig), sv, 0);
 465  ++MY_CXT.count;
 466
 467  RETVAL = newRV_noinc(sv);
 468 OUTPUT:
 469  RETVAL
 470
 471 SV *gensig()
 472 PROTOTYPE:
 473 CODE:
 474  dMY_CXT;
 475  if (MY_CXT.count >= SIG_NBR) { croak(vmg_toomanysigs); }
 476  RETVAL = newSVuv(vmg_gensig());
 477 OUTPUT:
 478  RETVAL
 479
 480 SV *getsig(SV *wiz)
 481 PROTOTYPE: $
 482 CODE:
 483  if (!SvROK(wiz)) { croak(vmg_invalid_wiz); }
 484  RETVAL = newSVuv(SV2MGWIZ(SvRV(wiz))->sig);
 485 OUTPUT:
 486  RETVAL
 487
 488 SV *cast(SV *sv, SV *wiz, ...)
 489 PROTOTYPE: \[$@%&*]$@
 490 PREINIT:
 491  AV *args = NULL;
 492  SV *ret;
 493 CODE:
 494  dMY_CXT;
 495  if (SvROK(wiz)) {
 496   wiz = SvRV(wiz);
 497  } else if (SvOK(wiz)) {
 498   char buf[8];
 499   SV **old;
 500   U16 sig = vmg_sv2sig(wiz);
 501   if (old = hv_fetch(MY_CXT.wizz, buf, sprintf(buf, "%u", sig), 0)) {
 502    wiz = *old;
 503   } else {
 504    XSRETURN_UNDEF;
 505   }
 506  } else {
 507   croak(vmg_invalid_sig);
 508  }
 509  if (items > 2) {
 510   I32 i;
 511   args = newAV();
 512   av_fill(args, items - 2);
 513   for (i = 2; i < items; ++i) {
 514    SV *arg = ST(i);
 515    SvREFCNT_inc(arg);
 516    if (av_store(args, i - 2, arg) == NULL) { croak(vmg_argstorefailed); }
 517   }
 518  }
 519  ret = newSVuv(vmg_cast(SvRV(sv), wiz, args));
 520  SvREFCNT_dec(args);
 521  RETVAL = ret;
 522 OUTPUT:
 523  RETVAL
 524
 525 SV *getdata(SV *sv, SV *wiz)
 526 PROTOTYPE: \[$@%&*]$
 527 PREINIT:
 528  SV *data;
 529  U16 sig;
 530 CODE:
 531  dMY_CXT;
 532  if (SvROK(wiz)) {
 533   sig = SV2MGWIZ(SvRV(wiz))->sig;
 534  } else if (SvOK(wiz)) {
 535   char buf[8];
 536   sig = vmg_sv2sig(wiz);
 537   if (!hv_fetch(MY_CXT.wizz, buf, sprintf(buf, "%u", sig), 0)) {
 538    XSRETURN_UNDEF;
 539   }
 540  } else {
 541   croak(vmg_invalid_wiz);
 542  }
 543  data = vmg_data_get(SvRV(sv), sig);
 544  if (!data) { XSRETURN_UNDEF; }
 545  ST(0) = newSVsv(data);
 546  XSRETURN(1);
 547
 548 SV *dispell(SV *sv, SV *wiz)
 549 PROTOTYPE: \[$@%&*]$
 550 PREINIT:
 551  U16 sig;
 552 CODE:
 553  dMY_CXT;
 554  if (SvROK(wiz)) {
 555   sig = SV2MGWIZ(SvRV(wiz))->sig;
 556  } else if (SvOK(wiz)) {
 557   char buf[8];
 558   sig = vmg_sv2sig(wiz);
 559   if (!hv_fetch(MY_CXT.wizz, buf, sprintf(buf, "%u", sig), 0)) {
 560    XSRETURN_UNDEF;
 561   }
 562  } else {
 563   croak(vmg_invalid_wiz);
 564  }
 565  RETVAL = newSVuv(vmg_dispell(SvRV(sv), sig));
 566 OUTPUT:
 567  RETVAL