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 #undef VOID2
  16 #ifdef __cplusplus
  17 # define VOID2(T, P) static_cast<T>(P)
  18 #else
  19 # define VOID2(T, P) (P)
  20 #endif
  21
  22 #ifndef VMG_PERL_PATCHLEVEL
  23 # ifdef PERL_PATCHNUM
  24 #  define VMG_PERL_PATCHLEVEL PERL_PATCHNUM
  25 # else
  26 #  define VMG_PERL_PATCHLEVEL 0
  27 # endif
  28 #endif
  29
  30 #define VMG_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
  31
  32 #define VMG_HAS_PERL_BRANCH(R, V, S) (PERL_REVISION == (R) && PERL_VERSION == (V) && PERL_SUBVERSION >= (S))
  33
  34 #define VMG_HAS_PERL_MAINT(R, V, S, P) (PERL_REVISION == (R) && PERL_VERSION == (V) && (VMG_PERL_PATCHLEVEL >= (P) || (!VMG_PERL_PATCHLEVEL && PERL_SUBVERSION >= (S))))
  35
  36 /* --- Threads and multiplicity -------------------------------------------- */
  37
  38 #ifndef NOOP
  39 # define NOOP
  40 #endif
  41
  42 #ifndef dNOOP
  43 # define dNOOP
  44 #endif
  45
  46 /* Safe unless stated otherwise in Makefile.PL */
  47 #ifndef VMG_FORKSAFE
  48 # define VMG_FORKSAFE 1
  49 #endif
  50
  51 #ifndef VMG_MULTIPLICITY
  52 # if defined(MULTIPLICITY)
  53 #  define VMG_MULTIPLICITY 1
  54 # else
  55 #  define VMG_MULTIPLICITY 0
  56 # endif
  57 #endif
  58 #if VMG_MULTIPLICITY
  59 # ifndef PERL_IMPLICIT_CONTEXT
  60 #  error MULTIPLICITY builds must set PERL_IMPLICIT_CONTEXT
  61 # endif
  62 #endif
  63
  64 #if VMG_MULTIPLICITY && defined(USE_ITHREADS) && defined(dMY_CXT) && defined(MY_CXT) && defined(START_MY_CXT) && defined(MY_CXT_INIT) && (defined(MY_CXT_CLONE) || defined(dMY_CXT_SV))
  65 # ifndef VMG_THREADSAFE
  66 #  define VMG_THREADSAFE 1
  67 # endif
  68 # ifndef MY_CXT_CLONE
  69 #  define MY_CXT_CLONE \
  70     dMY_CXT_SV;                                                      \
  71     my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1)); \
  72     Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t); \
  73     sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
  74 # endif
  75 #else
  76 # undef  VMG_THREADSAFE
  77 # define VMG_THREADSAFE 0
  78 # undef  dMY_CXT
  79 # define dMY_CXT      dNOOP
  80 # undef  MY_CXT
  81 # define MY_CXT       vmg_globaldata
  82 # undef  START_MY_CXT
  83 # define START_MY_CXT STATIC my_cxt_t MY_CXT;
  84 # undef  MY_CXT_INIT
  85 # define MY_CXT_INIT  NOOP
  86 # undef  MY_CXT_CLONE
  87 # define MY_CXT_CLONE NOOP
  88 #endif
  89
  90 #if VMG_THREADSAFE
  91 # define VMG_LOCK(M)   MUTEX_LOCK(M)
  92 # define VMG_UNLOCK(M) MUTEX_UNLOCK(M)
  93 #else
  94 # define VMG_LOCK(M)
  95 # define VMG_UNLOCK(M)
  96 #endif
  97
  98 /* --- Compatibility ------------------------------------------------------- */
  99
 100 #ifndef Newx
 101 # define Newx(v, n, c) New(0, v, n, c)
 102 #endif
 103
 104 #ifndef SvMAGIC_set
 105 # define SvMAGIC_set(sv, val) (SvMAGIC(sv) = (val))
 106 #endif
 107
 108 #ifndef SvRV_const
 109 # define SvRV_const(sv) SvRV((SV *) sv)
 110 #endif
 111
 112 #ifndef SvREFCNT_inc_simple_void
 113 # define SvREFCNT_inc_simple_void(sv) ((void) SvREFCNT_inc(sv))
 114 #endif
 115
 116 #ifndef mPUSHu
 117 # define mPUSHu(U) PUSHs(sv_2mortal(newSVuv(U)))
 118 #endif
 119
 120 #ifndef PERL_MAGIC_ext
 121 # define PERL_MAGIC_ext '~'
 122 #endif
 123
 124 #ifndef PERL_MAGIC_tied
 125 # define PERL_MAGIC_tied 'P'
 126 #endif
 127
 128 #ifndef MGf_LOCAL
 129 # define MGf_LOCAL 0
 130 #endif
 131
 132 #ifndef IN_PERL_COMPILETIME
 133 # define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling)
 134 #endif
 135
 136 #ifdef DEBUGGING
 137 # define VMG_ASSERT(C) assert(C)
 138 #else
 139 # define VMG_ASSERT(C)
 140 #endif
 141
 142 /* uvar magic and Hash::Util::FieldHash were commited with 28419, but we only
 143  * enable them on 5.10 */
 144 #if VMG_HAS_PERL(5, 10, 0)
 145 # define VMG_UVAR 1
 146 #else
 147 # define VMG_UVAR 0
 148 #endif
 149
 150 #if VMG_HAS_PERL_MAINT(5, 11, 0, 32969) || VMG_HAS_PERL(5, 12, 0)
 151 # define VMG_COMPAT_SCALAR_LENGTH_NOLEN 1
 152 #else
 153 # define VMG_COMPAT_SCALAR_LENGTH_NOLEN 0
 154 #endif
 155
 156 #if VMG_HAS_PERL(5, 17, 4)
 157 # define VMG_COMPAT_SCALAR_NOLEN 1
 158 #else
 159 # define VMG_COMPAT_SCALAR_NOLEN 0
 160 #endif
 161
 162 /* Applied to dev-5.9 as 25854, integrated to maint-5.8 as 28160, partially
 163  * reverted to dev-5.11 as 9cdcb38b */
 164 #if VMG_HAS_PERL_MAINT(5, 8, 9, 28160) || VMG_HAS_PERL_MAINT(5, 9, 3, 25854) || VMG_HAS_PERL(5, 10, 0)
 165 # ifndef VMG_COMPAT_ARRAY_PUSH_NOLEN
 166 #  if VMG_HAS_PERL(5, 11, 0)
 167 #   define VMG_COMPAT_ARRAY_PUSH_NOLEN 0
 168 #  else
 169 #   define VMG_COMPAT_ARRAY_PUSH_NOLEN 1
 170 #  endif
 171 # endif
 172 # ifndef VMG_COMPAT_ARRAY_PUSH_NOLEN_VOID
 173 #  define VMG_COMPAT_ARRAY_PUSH_NOLEN_VOID 1
 174 # endif
 175 #else
 176 # ifndef VMG_COMPAT_ARRAY_PUSH_NOLEN
 177 #  define VMG_COMPAT_ARRAY_PUSH_NOLEN 0
 178 # endif
 179 # ifndef VMG_COMPAT_ARRAY_PUSH_NOLEN_VOID
 180 #  define VMG_COMPAT_ARRAY_PUSH_NOLEN_VOID 0
 181 # endif
 182 #endif
 183
 184 /* Applied to dev-5.11 as 34908 */
 185 #if VMG_HAS_PERL_MAINT(5, 11, 0, 34908) || VMG_HAS_PERL(5, 12, 0)
 186 # define VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID 1
 187 #else
 188 # define VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID 0
 189 #endif
 190
 191 /* Applied to dev-5.9 as 31473 (see #43357), integrated to maint-5.8 as 32542 */
 192 #if VMG_HAS_PERL_MAINT(5, 8, 9, 32542) || VMG_HAS_PERL_MAINT(5, 9, 5, 31473) || VMG_HAS_PERL(5, 10, 0)
 193 # define VMG_COMPAT_ARRAY_UNDEF_CLEAR 1
 194 #else
 195 # define VMG_COMPAT_ARRAY_UNDEF_CLEAR 0
 196 #endif
 197
 198 #if VMG_HAS_PERL(5, 11, 0)
 199 # define VMG_COMPAT_HASH_DELETE_NOUVAR_VOID 1
 200 #else
 201 # define VMG_COMPAT_HASH_DELETE_NOUVAR_VOID 0
 202 #endif
 203
 204 #if VMG_HAS_PERL(5, 17, 0)
 205 # define VMG_COMPAT_CODE_COPY_CLONE 1
 206 #else
 207 # define VMG_COMPAT_CODE_COPY_CLONE 0
 208 #endif
 209
 210 #if VMG_HAS_PERL(5, 13, 2)
 211 # define VMG_COMPAT_GLOB_GET 1
 212 #else
 213 # define VMG_COMPAT_GLOB_GET 0
 214 #endif
 215
 216 #define VMG_PROPAGATE_ERRSV_NEEDS_TRAMPOLINE (VMG_HAS_PERL(5, 10, 0) && !VMG_HAS_PERL(5, 10, 1))
 217
 218 /* NewOp() isn't public in perl 5.8.0. */
 219 #define VMG_RESET_RMG_NEEDS_TRAMPOLINE (VMG_UVAR && (VMG_THREADSAFE || !VMG_HAS_PERL(5, 8, 1)))
 220
 221 /* ... Bug-free mg_magical ................................................. */
 222
 223 /* See the discussion at http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2008-01/msg00036.html */
 224
 225 #if VMG_HAS_PERL(5, 11, 3)
 226
 227 #define vmg_mg_magical(S) mg_magical(S)
 228
 229 #else
 230
 231 static void vmg_mg_magical(SV *sv) {
 232  const MAGIC *mg;
 233
 234  SvMAGICAL_off(sv);
 235  if ((mg = SvMAGIC(sv))) {
 236   do {
 237    const MGVTBL* const vtbl = mg->mg_virtual;
 238    if (vtbl) {
 239     if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
 240      SvGMAGICAL_on(sv);
 241     if (vtbl->svt_set)
 242      SvSMAGICAL_on(sv);
 243     if (vtbl->svt_clear)
 244      SvRMAGICAL_on(sv);
 245    }
 246   } while ((mg = mg->mg_moremagic));
 247   if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)))
 248    SvRMAGICAL_on(sv);
 249  }
 250 }
 251
 252 #endif
 253
 254 /* --- Trampoline ops ------------------------------------------------------ */
 255
 256 #define VMG_NEEDS_TRAMPOLINE VMG_PROPAGATE_ERRSV_NEEDS_TRAMPOLINE || VMG_RESET_RMG_NEEDS_TRAMPOLINE
 257
 258 #if VMG_NEEDS_TRAMPOLINE
 259
 260 typedef struct {
 261  OP   temp;
 262  SVOP target;
 263 } vmg_trampoline;
 264
 265 static void vmg_trampoline_init(vmg_trampoline *t, OP *(*cb)(pTHX)) {
 266  t->temp.op_type    = OP_STUB;
 267  t->temp.op_ppaddr  = 0;
 268  t->temp.op_next    = (OP *) &t->target;
 269  t->temp.op_flags   = 0;
 270  t->temp.op_private = 0;
 271
 272  t->target.op_type    = OP_STUB;
 273  t->target.op_ppaddr  = cb;
 274  t->target.op_next    = NULL;
 275  t->target.op_flags   = 0;
 276  t->target.op_private = 0;
 277  t->target.op_sv      = NULL;
 278 }
 279
 280 static OP *vmg_trampoline_bump(pTHX_ vmg_trampoline *t, SV *sv, OP *o) {
 281 #define vmg_trampoline_bump(T, S, O) vmg_trampoline_bump(aTHX_ (T), (S), (O))
 282  t->temp         = *o;
 283  t->temp.op_next = (OP *) &t->target;
 284
 285  t->target.op_sv   = sv;
 286  t->target.op_next = o->op_next;
 287
 288  return &t->temp;
 289 }
 290
 291 #endif /* VMG_NEEDS_TRAMPOLINE */
 292
 293 /* --- Cleaner version of sv_magicext() ------------------------------------ */
 294
 295 static MAGIC *vmg_sv_magicext(pTHX_ SV *sv, SV *obj, const MGVTBL *vtbl, const void *ptr, I32 len) {
 296 #define vmg_sv_magicext(S, O, V, P, L) vmg_sv_magicext(aTHX_ (S), (O), (V), (P), (L))
 297  MAGIC *mg;
 298
 299  mg = sv_magicext(sv, obj, PERL_MAGIC_ext, vtbl, ptr, len);
 300  if (!mg)
 301   return NULL;
 302
 303  mg->mg_private = 0;
 304
 305  if (vtbl->svt_copy)
 306   mg->mg_flags |= MGf_COPY;
 307 #if MGf_DUP
 308  if (vtbl->svt_dup)
 309   mg->mg_flags |= MGf_DUP;
 310 #endif /* MGf_DUP */
 311 #if MGf_LOCAL
 312  if (vtbl->svt_local)
 313   mg->mg_flags |= MGf_LOCAL;
 314 #endif /* MGf_LOCAL */
 315
 316  if (mg->mg_flags & MGf_REFCOUNTED)
 317   SvREFCNT_dec(obj);
 318
 319  return mg;
 320 }
 321
 322 /* --- Safe version of call_sv() ------------------------------------------- */
 323
 324 static I32 vmg_call_sv(pTHX_ SV *sv, I32 flags, int (*cleanup)(pTHX_ void *), void *ud) {
 325 #define vmg_call_sv(S, F, C, U) vmg_call_sv(aTHX_ (S), (F), (C), (U))
 326  I32 ret, cxix;
 327  PERL_CONTEXT saved_cx;
 328  SV *old_err = NULL;
 329
 330  if (SvTRUE(ERRSV)) {
 331   old_err = newSVsv(ERRSV);
 332   sv_setsv(ERRSV, &PL_sv_undef);
 333  }
 334
 335  cxix     = (cxstack_ix < cxstack_max) ? (cxstack_ix + 1) : Perl_cxinc(aTHX);
 336  /* The last popped context will be reused by call_sv(), but our callers may
 337   * still need its previous value. Back it up so that it isn't clobbered. */
 338  saved_cx = cxstack[cxix];
 339
 340  ret = call_sv(sv, flags | G_EVAL);
 341
 342  cxstack[cxix] = saved_cx;
 343
 344  if (SvTRUE(ERRSV)) {
 345   SvREFCNT_dec(old_err);
 346
 347   if (IN_PERL_COMPILETIME) {
 348    if (!PL_in_eval) {
 349     if (PL_errors)
 350      sv_catsv(PL_errors, ERRSV);
 351     else
 352      Perl_warn(aTHX_ "%s", SvPV_nolen(ERRSV));
 353     SvCUR_set(ERRSV, 0);
 354    }
 355 #if VMG_HAS_PERL(5, 10, 0) || defined(PL_parser)
 356    if (PL_parser)
 357     ++PL_parser->error_count;
 358 #elif defined(PL_error_count)
 359    ++PL_error_count;
 360 #else
 361    ++PL_Ierror_count;
 362 #endif
 363   } else {
 364    if (!cleanup || cleanup(aTHX_ ud))
 365     croak(NULL);
 366   }
 367  } else {
 368   if (old_err) {
 369    sv_setsv(ERRSV, old_err);
 370    SvREFCNT_dec(old_err);
 371   }
 372  }
 373
 374  return ret;
 375 }
 376
 377 /* --- Stolen chunk of B --------------------------------------------------- */
 378
 379 typedef enum {
 380  OPc_NULL,
 381  OPc_BASEOP,
 382  OPc_UNOP,
 383  OPc_BINOP,
 384  OPc_LOGOP,
 385  OPc_LISTOP,
 386  OPc_PMOP,
 387  OPc_SVOP,
 388  OPc_PADOP,
 389  OPc_PVOP,
 390  OPc_LOOP,
 391  OPc_COP,
 392 #if VMG_HAS_PERL(5, 21, 5)
 393  OPc_METHOP,
 394 #endif
 395 #if VMG_HAS_PERL(5, 21, 7)
 396  OPc_UNOP_AUX,
 397 #endif
 398  OPc_MAX
 399 } opclass;
 400
 401 static const char *const vmg_opclassnames[] = {
 402  "B::NULL",
 403  "B::OP",
 404  "B::UNOP",
 405  "B::BINOP",
 406  "B::LOGOP",
 407  "B::LISTOP",
 408  "B::PMOP",
 409  "B::SVOP",
 410  "B::PADOP",
 411  "B::PVOP",
 412  "B::LOOP",
 413  "B::COP",
 414 #if VMG_HAS_PERL(5, 21, 5)
 415  "B::METHOP",
 416 #endif
 417 #if VMG_HAS_PERL(5, 21, 7)
 418  "B::UNOP_AUX",
 419 #endif
 420  NULL
 421 };
 422
 423 static opclass vmg_opclass(const OP *o) {
 424 #if 0
 425  if (!o)
 426   return OPc_NULL;
 427 #endif
 428
 429  if (o->op_type == 0)
 430   return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
 431
 432  if (o->op_type == OP_SASSIGN)
 433   return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
 434
 435  if (o->op_type == OP_AELEMFAST) {
 436 #if PERL_VERSION <= 14
 437   if (o->op_flags & OPf_SPECIAL)
 438    return OPc_BASEOP;
 439   else
 440 #endif
 441 #ifdef USE_ITHREADS
 442    return OPc_PADOP;
 443 #else
 444    return OPc_SVOP;
 445 #endif
 446  }
 447
 448 #ifdef USE_ITHREADS
 449  if (o->op_type == OP_GV || o->op_type == OP_GVSV || o->op_type == OP_RCATLINE)
 450   return OPc_PADOP;
 451 #endif
 452
 453  switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
 454   case OA_BASEOP:
 455    return OPc_BASEOP;
 456   case OA_UNOP:
 457    return OPc_UNOP;
 458   case OA_BINOP:
 459    return OPc_BINOP;
 460   case OA_LOGOP:
 461    return OPc_LOGOP;
 462   case OA_LISTOP:
 463    return OPc_LISTOP;
 464   case OA_PMOP:
 465    return OPc_PMOP;
 466   case OA_SVOP:
 467    return OPc_SVOP;
 468   case OA_PADOP:
 469    return OPc_PADOP;
 470   case OA_PVOP_OR_SVOP:
 471    return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF)) ? OPc_SVOP : OPc_PVOP;
 472   case OA_LOOP:
 473    return OPc_LOOP;
 474   case OA_COP:
 475    return OPc_COP;
 476   case OA_BASEOP_OR_UNOP:
 477    return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
 478   case OA_FILESTATOP:
 479    return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
 480 #ifdef USE_ITHREADS
 481            (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
 482 #else
 483            (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
 484 #endif
 485   case OA_LOOPEXOP:
 486    if (o->op_flags & OPf_STACKED)
 487     return OPc_UNOP;
 488    else if (o->op_flags & OPf_SPECIAL)
 489     return OPc_BASEOP;
 490    else
 491     return OPc_PVOP;
 492 #if VMG_HAS_PERL(5, 21, 5)
 493   case OA_METHOP:
 494    return OPc_METHOP;
 495 #endif
 496 #if VMG_HAS_PERL(5, 21, 7)
 497   case OA_UNOP_AUX:
 498    return OPc_UNOP_AUX;
 499 #endif
 500  }
 501
 502  return OPc_BASEOP;
 503 }
 504
 505 /* --- Error messages ------------------------------------------------------ */
 506
 507 static const char vmg_invalid_wiz[] = "Invalid wizard object";
 508 static const char vmg_wrongargnum[] = "Wrong number of arguments";
 509
 510 /* --- Context-safe global data -------------------------------------------- */
 511
 512 #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
 513
 514 typedef struct {
 515  HV             *b__op_stashes[OPc_MAX];
 516  I32             depth;
 517  MAGIC          *freed_tokens;
 518 #if VMG_PROPAGATE_ERRSV_NEEDS_TRAMPOLINE
 519  vmg_trampoline  propagate_errsv;
 520 #endif
 521 #if VMG_RESET_RMG_NEEDS_TRAMPOLINE
 522  vmg_trampoline  reset_rmg;
 523 #endif
 524 } my_cxt_t;
 525
 526 START_MY_CXT
 527
 528 /* --- <vmg_vtable> structure ---------------------------------------------- */
 529
 530 #if VMG_THREADSAFE
 531
 532 typedef struct {
 533  MGVTBL *vtbl;
 534  U32     refcount;
 535 } vmg_vtable;
 536
 537 static vmg_vtable *vmg_vtable_alloc(pTHX) {
 538 #define vmg_vtable_alloc() vmg_vtable_alloc(aTHX)
 539  vmg_vtable *t;
 540
 541  t = VOID2(vmg_vtable *, PerlMemShared_malloc(sizeof *t));
 542
 543  t->vtbl     = VOID2(MGVTBL *, PerlMemShared_malloc(sizeof *t->vtbl));
 544  t->refcount = 1;
 545
 546  return t;
 547 }
 548
 549 #define vmg_vtable_vtbl(T) (T)->vtbl
 550
 551 static perl_mutex vmg_vtable_refcount_mutex;
 552
 553 static vmg_vtable *vmg_vtable_dup(pTHX_ vmg_vtable *t) {
 554 #define vmg_vtable_dup(T) vmg_vtable_dup(aTHX_ (T))
 555  VMG_LOCK(&vmg_vtable_refcount_mutex);
 556  ++t->refcount;
 557  VMG_UNLOCK(&vmg_vtable_refcount_mutex);
 558
 559  return t;
 560 }
 561
 562 static void vmg_vtable_free(pTHX_ vmg_vtable *t) {
 563 #define vmg_vtable_free(T) vmg_vtable_free(aTHX_ (T))
 564  U32 refcount;
 565
 566  VMG_LOCK(&vmg_vtable_refcount_mutex);
 567  refcount = --t->refcount;
 568  VMG_UNLOCK(&vmg_vtable_refcount_mutex);
 569
 570  if (!refcount) {
 571   PerlMemShared_free(t->vtbl);
 572   PerlMemShared_free(t);
 573  }
 574 }
 575
 576 #else /* VMG_THREADSAFE */
 577
 578 typedef MGVTBL vmg_vtable;
 579
 580 static vmg_vtable *vmg_vtable_alloc(pTHX) {
 581 #define vmg_vtable_alloc() vmg_vtable_alloc(aTHX)
 582  vmg_vtable *t;
 583
 584  Newx(t, 1, vmg_vtable);
 585
 586  return t;
 587 }
 588
 589 #define vmg_vtable_vtbl(T) ((MGVTBL *) (T))
 590
 591 #define vmg_vtable_free(T) Safefree(T)
 592
 593 #endif /* !VMG_THREADSAFE */
 594
 595 /* --- <vmg_wizard> structure ---------------------------------------------- */
 596
 597 typedef struct {
 598  vmg_vtable *vtable;
 599
 600  U8 opinfo;
 601  U8 uvar;
 602
 603  SV *cb_data;
 604  SV *cb_get, *cb_set, *cb_len, *cb_clear, *cb_free;
 605  SV *cb_copy;
 606  SV *cb_dup;
 607 #if MGf_LOCAL
 608  SV *cb_local;
 609 #endif /* MGf_LOCAL */
 610 #if VMG_UVAR
 611  SV *cb_fetch, *cb_store, *cb_exists, *cb_delete;
 612 #endif /* VMG_UVAR */
 613 } vmg_wizard;
 614
 615 static void vmg_op_info_init(pTHX_ unsigned int opinfo);
 616
 617 static vmg_wizard *vmg_wizard_alloc(pTHX_ UV opinfo) {
 618 #define vmg_wizard_alloc(O) vmg_wizard_alloc(aTHX_ (O))
 619  vmg_wizard *w;
 620
 621  Newx(w, 1, vmg_wizard);
 622
 623  w->uvar   = 0;
 624  w->opinfo = (U8) ((opinfo < 255) ? opinfo : 255);
 625  if (w->opinfo)
 626   vmg_op_info_init(aTHX_ w->opinfo);
 627
 628  w->vtable = vmg_vtable_alloc();
 629
 630  return w;
 631 }
 632
 633 static void vmg_wizard_free(pTHX_ vmg_wizard *w) {
 634 #define vmg_wizard_free(W) vmg_wizard_free(aTHX_ (W))
 635  if (!w)
 636   return;
 637
 638  /* During global destruction, any of the callbacks may already have been
 639   * freed, so we can't rely on still being able to access them. */
 640  if (!PL_dirty) {
 641   SvREFCNT_dec(w->cb_data);
 642   SvREFCNT_dec(w->cb_get);
 643   SvREFCNT_dec(w->cb_set);
 644   SvREFCNT_dec(w->cb_len);
 645   SvREFCNT_dec(w->cb_clear);
 646   SvREFCNT_dec(w->cb_free);
 647   SvREFCNT_dec(w->cb_copy);
 648 #if 0
 649   SvREFCNT_dec(w->cb_dup);
 650 #endif
 651 #if MGf_LOCAL
 652   SvREFCNT_dec(w->cb_local);
 653 #endif /* MGf_LOCAL */
 654 #if VMG_UVAR
 655   SvREFCNT_dec(w->cb_fetch);
 656   SvREFCNT_dec(w->cb_store);
 657   SvREFCNT_dec(w->cb_exists);
 658   SvREFCNT_dec(w->cb_delete);
 659 #endif /* VMG_UVAR */
 660  }
 661
 662  /* PerlMemShared_free() and Safefree() are still fine during global
 663   * destruction though. */
 664  vmg_vtable_free(w->vtable);
 665  Safefree(w);
 666
 667  return;
 668 }
 669
 670 #if VMG_THREADSAFE
 671
 672 #define VMG_CLONE_CB(N) \
 673  z->cb_ ## N = (w->cb_ ## N) ? SvREFCNT_inc(sv_dup(w->cb_ ## N, params)) \
 674                              : NULL;
 675
 676 static const vmg_wizard *vmg_wizard_dup(pTHX_ const vmg_wizard *w, CLONE_PARAMS *params) {
 677 #define vmg_wizard_dup(W, P) vmg_wizard_dup(aTHX_ (W), (P))
 678  vmg_wizard *z;
 679
 680  if (!w)
 681   return NULL;
 682
 683  Newx(z, 1, vmg_wizard);
 684
 685  z->vtable = vmg_vtable_dup(w->vtable);
 686  z->uvar   = w->uvar;
 687  z->opinfo = w->opinfo;
 688
 689  VMG_CLONE_CB(data);
 690  VMG_CLONE_CB(get);
 691  VMG_CLONE_CB(set);
 692  VMG_CLONE_CB(len);
 693  VMG_CLONE_CB(clear);
 694  VMG_CLONE_CB(free);
 695  VMG_CLONE_CB(copy);
 696  VMG_CLONE_CB(dup);
 697 #if MGf_LOCAL
 698  VMG_CLONE_CB(local);
 699 #endif /* MGf_LOCAL */
 700 #if VMG_UVAR
 701  VMG_CLONE_CB(fetch);
 702  VMG_CLONE_CB(store);
 703  VMG_CLONE_CB(exists);
 704  VMG_CLONE_CB(delete);
 705 #endif /* VMG_UVAR */
 706
 707  return z;
 708 }
 709
 710 #endif /* VMG_THREADSAFE */
 711
 712 #define vmg_wizard_id(W) PTR2IV(vmg_vtable_vtbl((W)->vtable))
 713
 714 /* --- Wizard SV objects --------------------------------------------------- */
 715
 716 static int vmg_wizard_sv_free(pTHX_ SV *sv, MAGIC *mg) {
 717  vmg_wizard_free((vmg_wizard *) mg->mg_ptr);
 718
 719  return 0;
 720 }
 721
 722 #if VMG_THREADSAFE
 723
 724 static int vmg_wizard_sv_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *params) {
 725  mg->mg_ptr = (char *) vmg_wizard_dup((const vmg_wizard *) mg->mg_ptr, params);
 726
 727  return 0;
 728 }
 729
 730 #endif /* VMG_THREADSAFE */
 731
 732 static MGVTBL vmg_wizard_sv_vtbl = {
 733  NULL,               /* get */
 734  NULL,               /* set */
 735  NULL,               /* len */
 736  NULL,               /* clear */
 737  vmg_wizard_sv_free, /* free */
 738  NULL,               /* copy */
 739 #if VMG_THREADSAFE
 740  vmg_wizard_sv_dup,  /* dup */
 741 #else
 742  NULL,               /* dup */
 743 #endif
 744 #if MGf_LOCAL
 745  NULL,               /* local */
 746 #endif /* MGf_LOCAL */
 747 };
 748
 749 static SV *vmg_wizard_sv_new(pTHX_ const vmg_wizard *w) {
 750 #define vmg_wizard_sv_new(W) vmg_wizard_sv_new(aTHX_ (W))
 751  SV *wiz;
 752
 753 #if VMG_THREADSAFE
 754  wiz = newSV(0);
 755 #else
 756  wiz = newSViv(PTR2IV(w));
 757 #endif
 758
 759  vmg_sv_magicext(wiz, NULL, &vmg_wizard_sv_vtbl, w, 0);
 760
 761  SvREADONLY_on(wiz);
 762
 763  return wiz;
 764 }
 765
 766 #if VMG_THREADSAFE
 767
 768 #define vmg_sv_has_wizard_type(S) (SvTYPE(S) >= SVt_PVMG)
 769
 770 static const vmg_wizard *vmg_wizard_from_sv_nocheck(const SV *wiz) {
 771  MAGIC *mg;
 772
 773  for (mg = SvMAGIC(wiz); mg; mg = mg->mg_moremagic) {
 774   if (mg->mg_type == PERL_MAGIC_ext && mg->mg_virtual == &vmg_wizard_sv_vtbl)
 775    return (const vmg_wizard *) mg->mg_ptr;
 776  }
 777
 778  return NULL;
 779 }
 780
 781 #else /* VMG_THREADSAFE */
 782
 783 #define vmg_sv_has_wizard_type(S) SvIOK(S)
 784
 785 #define vmg_wizard_from_sv_nocheck(W) INT2PTR(const vmg_wizard *, SvIVX(W))
 786
 787 #endif /* !VMG_THREADSAFE */
 788
 789 #define vmg_wizard_from_sv(W) (vmg_sv_has_wizard_type(W) ? vmg_wizard_from_sv_nocheck(W) : NULL)
 790
 791 static const vmg_wizard *vmg_wizard_from_mg(const MAGIC *mg) {
 792  if (mg->mg_type == PERL_MAGIC_ext && mg->mg_len == HEf_SVKEY) {
 793   SV *sv = (SV *) mg->mg_ptr;
 794
 795   if (vmg_sv_has_wizard_type(sv))
 796    return vmg_wizard_from_sv_nocheck(sv);
 797  }
 798
 799  return NULL;
 800 }
 801
 802 #define vmg_wizard_from_mg_nocheck(M) vmg_wizard_from_sv_nocheck((const SV *) (M)->mg_ptr)
 803
 804 /* --- User-level functions implementation --------------------------------- */
 805
 806 static const MAGIC *vmg_find(const SV *sv, const vmg_wizard *w) {
 807  const MAGIC *mg;
 808  IV wid;
 809
 810  if (SvTYPE(sv) < SVt_PVMG)
 811   return NULL;
 812
 813  wid = vmg_wizard_id(w);
 814
 815  for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 816   const vmg_wizard *z = vmg_wizard_from_mg(mg);
 817
 818   if (z && vmg_wizard_id(z) == wid)
 819    return mg;
 820  }
 821
 822  return NULL;
 823 }
 824
 825 /* ... Construct private data .............................................. */
 826
 827 static SV *vmg_data_new(pTHX_ SV *ctor, SV *sv, SV **args, I32 items) {
 828 #define vmg_data_new(C, S, A, I) vmg_data_new(aTHX_ (C), (S), (A), (I))
 829  I32 i;
 830  SV *nsv;
 831
 832  dSP;
 833
 834  ENTER;
 835  SAVETMPS;
 836
 837  PUSHMARK(SP);
 838  EXTEND(SP, items + 1);
 839  PUSHs(sv_2mortal(newRV_inc(sv)));
 840  for (i = 0; i < items; ++i)
 841   PUSHs(args[i]);
 842  PUTBACK;
 843
 844  vmg_call_sv(ctor, G_SCALAR, 0, NULL);
 845
 846  SPAGAIN;
 847  nsv = POPs;
 848 #if VMG_HAS_PERL(5, 8, 3)
 849  SvREFCNT_inc_simple_void(nsv); /* Or it will be destroyed in FREETMPS */
 850 #else
 851  nsv = sv_newref(nsv);          /* Workaround some bug in SvREFCNT_inc() */
 852 #endif
 853  PUTBACK;
 854
 855  FREETMPS;
 856  LEAVE;
 857
 858  return nsv;
 859 }
 860
 861 static SV *vmg_data_get(pTHX_ SV *sv, const vmg_wizard *w) {
 862 #define vmg_data_get(S, W) vmg_data_get(aTHX_ (S), (W))
 863  const MAGIC *mg = vmg_find(sv, w);
 864
 865  return mg ? mg->mg_obj : NULL;
 866 }
 867
 868 /* ... Magic cast/dispell .................................................. */
 869
 870 #if VMG_UVAR
 871
 872 static I32 vmg_svt_val(pTHX_ IV, SV *);
 873
 874 typedef struct {
 875  struct ufuncs new_uf;
 876  struct ufuncs old_uf;
 877 } vmg_uvar_ud;
 878
 879 #endif /* VMG_UVAR */
 880
 881 static void vmg_mg_del(pTHX_ SV *sv, MAGIC *prevmagic, MAGIC *mg, MAGIC *moremagic) {
 882 #define vmg_mg_del(S, P, M, N) vmg_mg_del(aTHX_ (S), (P), (M), (N))
 883  dMY_CXT;
 884
 885  if (prevmagic)
 886   prevmagic->mg_moremagic = moremagic;
 887  else
 888   SvMAGIC_set(sv, moremagic);
 889
 890  /* Destroy private data */
 891 #if VMG_UVAR
 892  if (mg->mg_type == PERL_MAGIC_uvar) {
 893   Safefree(mg->mg_ptr);
 894  } else {
 895 #endif /* VMG_UVAR */
 896   if (mg->mg_obj != sv) {
 897    SvREFCNT_dec(mg->mg_obj);
 898    mg->mg_obj = NULL;
 899   }
 900   /* Unreference the wizard */
 901   SvREFCNT_dec((SV *) mg->mg_ptr);
 902   mg->mg_ptr = NULL;
 903 #if VMG_UVAR
 904  }
 905 #endif /* VMG_UVAR */
 906
 907  if (MY_CXT.depth) {
 908   mg->mg_moremagic    = MY_CXT.freed_tokens;
 909   MY_CXT.freed_tokens = mg;
 910  } else {
 911   mg->mg_moremagic = NULL;
 912   Safefree(mg);
 913  }
 914 }
 915
 916 static int vmg_magic_chain_free(pTHX_ MAGIC *mg, MAGIC *skip) {
 917 #define vmg_magic_chain_free(M, S) vmg_magic_chain_free(aTHX_ (M), (S))
 918  int skipped = 0;
 919
 920  while (mg) {
 921   MAGIC *moremagic = mg->mg_moremagic;
 922
 923   if (mg == skip)
 924    ++skipped;
 925   else
 926    Safefree(mg);
 927
 928   mg = moremagic;
 929  }
 930
 931  return skipped;
 932 }
 933
 934 static UV vmg_cast(pTHX_ SV *sv, const vmg_wizard *w, const SV *wiz, SV **args, I32 items) {
 935 #define vmg_cast(S, W, WIZ, A, I) vmg_cast(aTHX_ (S), (W), (WIZ), (A), (I))
 936  MAGIC  *mg;
 937  MGVTBL *t;
 938  SV     *data;
 939  U32     oldgmg;
 940
 941  if (vmg_find(sv, w))
 942   return 1;
 943
 944  oldgmg = SvGMAGICAL(sv);
 945
 946  data = (w->cb_data) ? vmg_data_new(w->cb_data, sv, args, items) : NULL;
 947
 948  t  = vmg_vtable_vtbl(w->vtable);
 949  mg = vmg_sv_magicext(sv, data, t, wiz, HEf_SVKEY);
 950
 951  if (SvTYPE(sv) < SVt_PVHV)
 952   goto done;
 953
 954  /* The GMAGICAL flag only says that a hash is tied or has uvar magic - get
 955   * magic is actually never called for them. If the GMAGICAL flag was off before
 956   * calling sv_magicext(), the hash isn't tied and has no uvar magic. If it's
 957   * now on, then this wizard has get magic. Hence we can work around the
 958   * get/clear shortcoming by turning the GMAGICAL flag off. If the current magic
 959   * has uvar callbacks, it will be turned back on later. */
 960  if (!oldgmg && SvGMAGICAL(sv))
 961   SvGMAGICAL_off(sv);
 962
 963 #if VMG_UVAR
 964  if (w->uvar) {
 965   MAGIC *prevmagic, *moremagic = NULL;
 966   vmg_uvar_ud ud;
 967
 968   ud.new_uf.uf_val   = vmg_svt_val;
 969   ud.new_uf.uf_set   = NULL;
 970   ud.new_uf.uf_index = 0;
 971   ud.old_uf.uf_val   = NULL;
 972   ud.old_uf.uf_set   = NULL;
 973   ud.old_uf.uf_index = 0;
 974
 975   /* One uvar magic in the chain is enough. */
 976   for (prevmagic = NULL, mg = SvMAGIC(sv); mg; prevmagic = mg, mg = moremagic) {
 977    moremagic = mg->mg_moremagic;
 978    if (mg->mg_type == PERL_MAGIC_uvar)
 979     break;
 980   }
 981
 982   if (mg) { /* Found another uvar magic. */
 983    struct ufuncs *uf = (struct ufuncs *) mg->mg_ptr;
 984    if (uf->uf_val == vmg_svt_val) {
 985     /* It's our uvar magic, nothing to do. oldgmg was true. */
 986     goto done;
 987    } else {
 988     /* It's another uvar magic, backup it and replace it by ours. */
 989     ud.old_uf = *uf;
 990     vmg_mg_del(sv, prevmagic, mg, moremagic);
 991    }
 992   }
 993
 994   sv_magic(sv, NULL, PERL_MAGIC_uvar, (const char *) &ud, sizeof(ud));
 995   vmg_mg_magical(sv);
 996   /* Our hash now carries uvar magic. The uvar/clear shortcoming has to be
 997    * handled by our uvar callback. */
 998  }
 999 #endif /* VMG_UVAR */
1000
1001 done:
1002  return 1;
1003 }
1004
1005 static UV vmg_dispell(pTHX_ SV *sv, const vmg_wizard *w) {
1006 #define vmg_dispell(S, W) vmg_dispell(aTHX_ (S), (W))
1007 #if VMG_UVAR
1008  U32 uvars = 0;
1009 #endif /* VMG_UVAR */
1010  MAGIC *mg, *prevmagic, *moremagic = NULL;
1011  IV wid = vmg_wizard_id(w);
1012
1013  if (SvTYPE(sv) < SVt_PVMG)
1014   return 0;
1015
1016  for (prevmagic = NULL, mg = SvMAGIC(sv); mg; prevmagic = mg, mg = moremagic) {
1017   const vmg_wizard *z;
1018
1019   moremagic = mg->mg_moremagic;
1020
1021   z = vmg_wizard_from_mg(mg);
1022   if (z) {
1023    IV zid = vmg_wizard_id(z);
1024
1025 #if VMG_UVAR
1026    if (zid == wid) {
1027     /* If the current has no uvar, short-circuit uvar deletion. */
1028     uvars = z->uvar ? (uvars + 1) : 0;
1029     break;
1030    } else if (z->uvar) {
1031     ++uvars;
1032     /* We can't break here since we need to find the ext magic to delete. */
1033    }
1034 #else /* VMG_UVAR */
1035    if (zid == wid)
1036     break;
1037 #endif /* !VMG_UVAR */
1038   }
1039  }
1040  if (!mg)
1041   return 0;
1042
1043  vmg_mg_del(sv, prevmagic, mg, moremagic);
1044
1045 #if VMG_UVAR
1046  if (uvars == 1 && SvTYPE(sv) >= SVt_PVHV) {
1047   /* mg was the first ext magic in the chain that had uvar */
1048
1049   for (mg = moremagic; mg; mg = mg->mg_moremagic) {
1050    const vmg_wizard *z = vmg_wizard_from_mg(mg);
1051
1052    if (z && z->uvar) {
1053     ++uvars;
1054     break;
1055    }
1056   }
1057
1058   if (uvars == 1) {
1059    vmg_uvar_ud *ud;
1060
1061    for (prevmagic = NULL, mg = SvMAGIC(sv); mg; prevmagic = mg, mg = moremagic){
1062     moremagic = mg->mg_moremagic;
1063     if (mg->mg_type == PERL_MAGIC_uvar)
1064      break;
1065    }
1066
1067    ud = (vmg_uvar_ud *) mg->mg_ptr;
1068    if (ud->old_uf.uf_val || ud->old_uf.uf_set) {
1069     /* Revert the original uvar magic. */
1070     struct ufuncs *uf;
1071     Newx(uf, 1, struct ufuncs);
1072     *uf = ud->old_uf;
1073     Safefree(ud);
1074     mg->mg_ptr = (char *) uf;
1075     mg->mg_len = sizeof(*uf);
1076    } else {
1077     /* Remove the uvar magic. */
1078     vmg_mg_del(sv, prevmagic, mg, moremagic);
1079    }
1080   }
1081  }
1082 #endif /* VMG_UVAR */
1083
1084  vmg_mg_magical(sv);
1085
1086  return 1;
1087 }
1088
1089 /* ... OP info ............................................................. */
1090
1091 #define VMG_OP_INFO_NAME   1
1092 #define VMG_OP_INFO_OBJECT 2
1093
1094 #if VMG_THREADSAFE
1095 static perl_mutex vmg_op_name_init_mutex;
1096 #endif
1097
1098 static U32           vmg_op_name_init      = 0;
1099 static unsigned char vmg_op_name_len[MAXO] = { 0 };
1100
1101 static void vmg_op_info_init(pTHX_ unsigned int opinfo) {
1102 #define vmg_op_info_init(W) vmg_op_info_init(aTHX_ (W))
1103  switch (opinfo) {
1104   case VMG_OP_INFO_NAME:
1105    VMG_LOCK(&vmg_op_name_init_mutex);
1106    if (!vmg_op_name_init) {
1107     OPCODE t;
1108     for (t = 0; t < OP_max; ++t)
1109      vmg_op_name_len[t] = strlen(PL_op_name[t]);
1110     vmg_op_name_init = 1;
1111    }
1112    VMG_UNLOCK(&vmg_op_name_init_mutex);
1113    break;
1114   case VMG_OP_INFO_OBJECT: {
1115    dMY_CXT;
1116    if (!MY_CXT.b__op_stashes[0]) {
1117     int c;
1118     require_pv("B.pm");
1119     for (c = OPc_NULL; c < OPc_MAX; ++c)
1120      MY_CXT.b__op_stashes[c] = gv_stashpv(vmg_opclassnames[c], 1);
1121    }
1122    break;
1123   }
1124   default:
1125    break;
1126  }
1127 }
1128
1129 static SV *vmg_op_info(pTHX_ unsigned int opinfo) {
1130 #define vmg_op_info(W) vmg_op_info(aTHX_ (W))
1131  if (!PL_op)
1132   return &PL_sv_undef;
1133
1134  switch (opinfo) {
1135   case VMG_OP_INFO_NAME: {
1136    OPCODE t = PL_op->op_type;
1137    return sv_2mortal(newSVpvn(PL_op_name[t], vmg_op_name_len[t]));
1138   }
1139   case VMG_OP_INFO_OBJECT: {
1140    dMY_CXT;
1141    return sv_bless(sv_2mortal(newRV_noinc(newSViv(PTR2IV(PL_op)))),
1142                    MY_CXT.b__op_stashes[vmg_opclass(PL_op)]);
1143   }
1144   default:
1145    break;
1146  }
1147
1148  return &PL_sv_undef;
1149 }
1150
1151 /* --- svt callbacks ------------------------------------------------------- */
1152
1153 #define VMG_CB_CALL_ARGS_MASK  15
1154 #define VMG_CB_CALL_ARGS_SHIFT 4
1155 #define VMG_CB_CALL_OPINFO     (VMG_OP_INFO_NAME|VMG_OP_INFO_OBJECT) /* 1|2 */
1156 #define VMG_CB_CALL_GUARD      4
1157
1158 static int vmg_dispell_guard_oncroak(pTHX_ void *ud) {
1159  dMY_CXT;
1160
1161  MY_CXT.depth--;
1162
1163  /* If we're at the upmost magic call and we're about to die, we can just free
1164   * the tokens right now, since we will jump past the problematic part of our
1165   * caller. */
1166  if (MY_CXT.depth == 0 && MY_CXT.freed_tokens) {
1167   vmg_magic_chain_free(MY_CXT.freed_tokens, NULL);
1168   MY_CXT.freed_tokens = NULL;
1169  }
1170
1171  return 1;
1172 }
1173
1174 static int vmg_dispell_guard_free(pTHX_ SV *sv, MAGIC *mg) {
1175  vmg_magic_chain_free((MAGIC *) mg->mg_ptr, NULL);
1176
1177  return 0;
1178 }
1179
1180 #if VMG_THREADSAFE
1181
1182 static int vmg_dispell_guard_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *params) {
1183  /* The freed magic tokens aren't cloned by perl because it cannot reach them
1184   * (they have been detached from their parent SV when they were enqueued).
1185   * Hence there's nothing to purge in the new thread. */
1186  mg->mg_ptr = NULL;
1187
1188  return 0;
1189 }
1190
1191 #endif /* VMG_THREADSAFE */
1192
1193 static MGVTBL vmg_dispell_guard_vtbl = {
1194  NULL,                   /* get */
1195  NULL,                   /* set */
1196  NULL,                   /* len */
1197  NULL,                   /* clear */
1198  vmg_dispell_guard_free, /* free */
1199  NULL,                   /* copy */
1200 #if VMG_THREADSAFE
1201  vmg_dispell_guard_dup,  /* dup */
1202 #else
1203  NULL,                   /* dup */
1204 #endif
1205 #if MGf_LOCAL
1206  NULL,                   /* local */
1207 #endif /* MGf_LOCAL */
1208 };
1209
1210 static SV *vmg_dispell_guard_new(pTHX_ MAGIC *root) {
1211 #define vmg_dispell_guard_new(R) vmg_dispell_guard_new(aTHX_ (R))
1212  SV *guard;
1213
1214  guard = sv_newmortal();
1215  vmg_sv_magicext(guard, NULL, &vmg_dispell_guard_vtbl, root, 0);
1216
1217  return guard;
1218 }
1219
1220 static int vmg_cb_call(pTHX_ SV *cb, unsigned int flags, SV *sv, ...) {
1221  va_list ap;
1222  int ret = 0;
1223  unsigned int i, args, opinfo;
1224  MAGIC **chain = NULL;
1225  SV *svr;
1226
1227  dSP;
1228
1229  args    = flags & VMG_CB_CALL_ARGS_MASK;
1230  flags >>= VMG_CB_CALL_ARGS_SHIFT;
1231  opinfo  = flags & VMG_CB_CALL_OPINFO;
1232
1233  ENTER;
1234  SAVETMPS;
1235
1236  PUSHMARK(SP);
1237  EXTEND(SP, args + 1);
1238  PUSHs(sv_2mortal(newRV_inc(sv)));
1239  va_start(ap, sv);
1240  for (i = 0; i < args; ++i) {
1241   SV *sva = va_arg(ap, SV *);
1242   PUSHs(sva ? sva : &PL_sv_undef);
1243  }
1244  va_end(ap);
1245  if (opinfo)
1246   XPUSHs(vmg_op_info(opinfo));
1247  PUTBACK;
1248
1249  if (flags & VMG_CB_CALL_GUARD) {
1250   dMY_CXT;
1251   MY_CXT.depth++;
1252   vmg_call_sv(cb, G_SCALAR, vmg_dispell_guard_oncroak, NULL);
1253   MY_CXT.depth--;
1254   if (MY_CXT.depth == 0 && MY_CXT.freed_tokens)
1255    chain = &MY_CXT.freed_tokens;
1256  } else {
1257   vmg_call_sv(cb, G_SCALAR, 0, NULL);
1258  }
1259
1260  SPAGAIN;
1261  svr = POPs;
1262  if (SvOK(svr))
1263   ret = (int) SvIV(svr);
1264  if (SvROK(svr))
1265   SvREFCNT_inc(svr);
1266  else
1267   svr = NULL;
1268  PUTBACK;
1269
1270  FREETMPS;
1271  LEAVE;
1272
1273  if (svr && !SvTEMP(svr))
1274   sv_2mortal(svr);
1275
1276  if (chain) {
1277   vmg_dispell_guard_new(*chain);
1278   *chain = NULL;
1279  }
1280
1281  return ret;
1282 }
1283
1284 #define VMG_CB_FLAGS(OI, A) \
1285         ((((unsigned int) (OI)) << VMG_CB_CALL_ARGS_SHIFT) | (A))
1286
1287 #define vmg_cb_call1(I, OI, S, A1) \
1288         vmg_cb_call(aTHX_ (I), VMG_CB_FLAGS((OI), 1), (S), (A1))
1289 #define vmg_cb_call2(I, OI, S, A1, A2) \
1290         vmg_cb_call(aTHX_ (I), VMG_CB_FLAGS((OI), 2), (S), (A1), (A2))
1291 #define vmg_cb_call3(I, OI, S, A1, A2, A3) \
1292         vmg_cb_call(aTHX_ (I), VMG_CB_FLAGS((OI), 3), (S), (A1), (A2), (A3))
1293
1294 /* ... Default no-op magic callback ........................................ */
1295
1296 static int vmg_svt_default_noop(pTHX_ SV *sv, MAGIC *mg) {
1297  return 0;
1298 }
1299
1300 /* ... get magic ........................................................... */
1301
1302 static int vmg_svt_get(pTHX_ SV *sv, MAGIC *mg) {
1303  const vmg_wizard *w = vmg_wizard_from_mg_nocheck(mg);
1304
1305  return vmg_cb_call1(w->cb_get, w->opinfo, sv, mg->mg_obj);
1306 }
1307
1308 #define vmg_svt_get_noop vmg_svt_default_noop
1309
1310 /* ... set magic ........................................................... */
1311
1312 static int vmg_svt_set(pTHX_ SV *sv, MAGIC *mg) {
1313  const vmg_wizard *w = vmg_wizard_from_mg_nocheck(mg);
1314
1315  return vmg_cb_call1(w->cb_set, w->opinfo, sv, mg->mg_obj);
1316 }
1317
1318 #define vmg_svt_set_noop vmg_svt_default_noop
1319
1320 /* ... len magic ........................................................... */
1321
1322 static U32 vmg_sv_len(pTHX_ SV *sv) {
1323 #define vmg_sv_len(S) vmg_sv_len(aTHX_ (S))
1324  STRLEN len;
1325 #if VMG_HAS_PERL(5, 9, 3)
1326  const U8 *s = VOID2(const U8 *, VOID2(const void *, SvPV_const(sv, len)));
1327 #else
1328  U8 *s = SvPV(sv, len);
1329 #endif
1330
1331  return DO_UTF8(sv) ? utf8_length(s, s + len) : len;
1332 }
1333
1334 static U32 vmg_svt_len(pTHX_ SV *sv, MAGIC *mg) {
1335  const vmg_wizard *w = vmg_wizard_from_mg_nocheck(mg);
1336  unsigned int opinfo = w->opinfo;
1337  U32 len, ret;
1338  SV *svr;
1339  svtype t = SvTYPE(sv);
1340
1341  dSP;
1342
1343  ENTER;
1344  SAVETMPS;
1345
1346  PUSHMARK(SP);
1347  EXTEND(SP, 3);
1348  PUSHs(sv_2mortal(newRV_inc(sv)));
1349  PUSHs(mg->mg_obj ? mg->mg_obj : &PL_sv_undef);
1350  if (t < SVt_PVAV) {
1351   len = vmg_sv_len(sv);
1352   mPUSHu(len);
1353  } else if (t == SVt_PVAV) {
1354   len = av_len((AV *) sv) + 1;
1355   mPUSHu(len);
1356  } else {
1357   len = 0;
1358   PUSHs(&PL_sv_undef);
1359  }
1360  if (opinfo)
1361   XPUSHs(vmg_op_info(opinfo));
1362  PUTBACK;
1363
1364  vmg_call_sv(w->cb_len, G_SCALAR, 0, NULL);
1365
1366  SPAGAIN;
1367  svr = POPs;
1368  ret = SvOK(svr) ? (U32) SvUV(svr) : len;
1369  if (t == SVt_PVAV)
1370   --ret;
1371  PUTBACK;
1372
1373  FREETMPS;
1374  LEAVE;
1375
1376  return ret;
1377 }
1378
1379 static U32 vmg_svt_len_noop(pTHX_ SV *sv, MAGIC *mg) {
1380  U32    len = 0;
1381  svtype t   = SvTYPE(sv);
1382
1383  if (t < SVt_PVAV) {
1384   len = vmg_sv_len(sv);
1385  } else if (t == SVt_PVAV) {
1386   len = (U32) av_len((AV *) sv);
1387  }
1388
1389  return len;
1390 }
1391
1392 /* ... clear magic ......................................................... */
1393
1394 static int vmg_svt_clear(pTHX_ SV *sv, MAGIC *mg) {
1395  const vmg_wizard *w = vmg_wizard_from_mg_nocheck(mg);
1396  unsigned int flags  = w->opinfo;
1397
1398 #if !VMG_HAS_PERL(5, 12, 0)
1399  flags |= VMG_CB_CALL_GUARD;
1400 #endif
1401
1402  return vmg_cb_call1(w->cb_clear, flags, sv, mg->mg_obj);
1403 }
1404
1405 #define vmg_svt_clear_noop vmg_svt_default_noop
1406
1407 /* ... free magic .......................................................... */
1408
1409 #if VMG_PROPAGATE_ERRSV_NEEDS_TRAMPOLINE
1410
1411 static OP *vmg_pp_propagate_errsv(pTHX) {
1412  SVOP *o = cSVOPx(PL_op);
1413
1414  if (o->op_sv) {
1415   sv_setsv(ERRSV, o->op_sv);
1416   SvREFCNT_dec(o->op_sv);
1417   o->op_sv = NULL;
1418  }
1419
1420  return NORMAL;
1421 }
1422
1423 #endif /* VMG_PROPAGATE_ERRSV_NEEDS_TRAMPOLINE */
1424
1425 static int vmg_propagate_errsv_free(pTHX_ SV *sv, MAGIC *mg) {
1426  if (mg->mg_obj)
1427   sv_setsv(ERRSV, mg->mg_obj);
1428
1429  return 0;
1430 }
1431
1432 /* perl is already kind enough to handle the cloning of the mg_obj member,
1433    hence we don't need to define a dup magic callback. */
1434
1435 static MGVTBL vmg_propagate_errsv_vtbl = {
1436  0,                        /* get */
1437  0,                        /* set */
1438  0,                        /* len */
1439  0,                        /* clear */
1440  vmg_propagate_errsv_free, /* free */
1441  0,                        /* copy */
1442  0,                        /* dup */
1443 #if MGf_LOCAL
1444  0,                        /* local */
1445 #endif /* MGf_LOCAL */
1446 };
1447
1448 typedef struct {
1449  SV  *sv;
1450  int  in_eval;
1451  I32  base;
1452 } vmg_svt_free_cleanup_ud;
1453
1454 static int vmg_svt_free_cleanup(pTHX_ void *ud_) {
1455  vmg_svt_free_cleanup_ud *ud = VOID2(vmg_svt_free_cleanup_ud *, ud_);
1456
1457  if (ud->in_eval) {
1458   U32 optype = PL_op ? PL_op->op_type : OP_NULL;
1459
1460   if (optype == OP_LEAVETRY || optype == OP_LEAVEEVAL) {
1461    SV *errsv = newSVsv(ERRSV);
1462
1463    FREETMPS;
1464    LEAVE_SCOPE(ud->base);
1465
1466 #if VMG_PROPAGATE_ERRSV_NEEDS_TRAMPOLINE
1467    if (optype == OP_LEAVETRY) {
1468     dMY_CXT;
1469     PL_op = vmg_trampoline_bump(&MY_CXT.propagate_errsv, errsv, PL_op);
1470    } else if (optype == OP_LEAVEEVAL) {
1471     SV *guard = sv_newmortal();
1472     vmg_sv_magicext(guard, errsv, &vmg_propagate_errsv_vtbl, NULL, 0);
1473    }
1474 #else /* !VMG_PROPAGATE_ERRSV_NEEDS_TRAMPOLINE */
1475 # if !VMG_HAS_PERL(5, 8, 9)
1476    {
1477     SV *guard = sv_newmortal();
1478     vmg_sv_magicext(guard, errsv, &vmg_propagate_errsv_vtbl, NULL, 0);
1479    }
1480 # else
1481    vmg_sv_magicext(ERRSV, errsv, &vmg_propagate_errsv_vtbl, NULL, 0);
1482 # endif
1483 #endif /* VMG_PROPAGATE_ERRSV_NEEDS_TRAMPOLINE */
1484
1485    SAVETMPS;
1486   }
1487
1488   /* Don't propagate */
1489   return 0;
1490  } else {
1491   SV    *sv = ud->sv;
1492   MAGIC *mg;
1493
1494   /* We are about to croak() while sv is being destroyed. Try to clean up
1495    * things a bit. */
1496   mg = SvMAGIC(sv);
1497   if (mg) {
1498    vmg_mg_del(sv, NULL, mg, mg->mg_moremagic);
1499    mg_magical(sv);
1500   }
1501   SvREFCNT_dec(sv);
1502
1503   vmg_dispell_guard_oncroak(aTHX_ NULL);
1504
1505   /* After that, propagate the error upwards. */
1506   return 1;
1507  }
1508 }
1509
1510 static int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) {
1511  vmg_svt_free_cleanup_ud ud;
1512  const vmg_wizard *w;
1513  int ret = 0;
1514  SV *svr;
1515
1516  dSP;
1517
1518  /* During global destruction, we cannot be sure that the wizard and its free
1519   * callback are still alive. */
1520  if (PL_dirty)
1521   return 0;
1522
1523  w = vmg_wizard_from_mg_nocheck(mg);
1524
1525  /* So that it survives the temp cleanup below */
1526  SvREFCNT_inc_simple_void(sv);
1527
1528 #if !(VMG_HAS_PERL_MAINT(5, 11, 0, 32686) || VMG_HAS_PERL(5, 12, 0))
1529  /* The previous magic tokens were freed but the magic chain wasn't updated, so
1530   * if you access the sv from the callback the old deleted magics will trigger
1531   * and cause memory misreads. Change 32686 solved it that way : */
1532  SvMAGIC_set(sv, mg);
1533 #endif
1534
1535  ud.sv = sv;
1536  if (cxstack_ix < cxstack_max) {
1537   ud.in_eval = (CxTYPE(cxstack + cxstack_ix + 1) == CXt_EVAL);
1538   ud.base    = ud.in_eval ? PL_scopestack[PL_scopestack_ix] : 0;
1539  } else {
1540   ud.in_eval = 0;
1541   ud.base    = 0;
1542  }
1543
1544  ENTER;
1545  SAVETMPS;
1546
1547  PUSHMARK(SP);
1548  EXTEND(SP, 2);
1549  PUSHs(sv_2mortal(newRV_inc(sv)));
1550  PUSHs(mg->mg_obj ? mg->mg_obj : &PL_sv_undef);
1551  if (w->opinfo)
1552   XPUSHs(vmg_op_info(w->opinfo));
1553  PUTBACK;
1554
1555  {
1556   dMY_CXT;
1557   MY_CXT.depth++;
1558   vmg_call_sv(w->cb_free, G_SCALAR, vmg_svt_free_cleanup, &ud);
1559   MY_CXT.depth--;
1560   if (MY_CXT.depth == 0 && MY_CXT.freed_tokens) {
1561    /* Free all the tokens in the chain but the current one (if it's present).
1562     * It will be taken care of by our caller, Perl_mg_free(). */
1563    vmg_magic_chain_free(MY_CXT.freed_tokens, mg);
1564    MY_CXT.freed_tokens = NULL;
1565   }
1566  }
1567
1568  SPAGAIN;
1569  svr = POPs;
1570  if (SvOK(svr))
1571   ret = (int) SvIV(svr);
1572  PUTBACK;
1573
1574  FREETMPS;
1575  LEAVE;
1576
1577  /* Calling SvREFCNT_dec() will trigger destructors in an infinite loop, so
1578   * we have to rely on SvREFCNT() being a lvalue. Heck, even the core does it */
1579  --SvREFCNT(sv);
1580
1581  /* Perl_mg_free will get rid of the magic and decrement mg->mg_obj and
1582   * mg->mg_ptr reference count */
1583  return ret;
1584 }
1585
1586 #define vmg_svt_free_noop vmg_svt_default_noop
1587
1588 #if VMG_HAS_PERL_MAINT(5, 11, 0, 33256) || VMG_HAS_PERL(5, 12, 0)
1589 # define VMG_SVT_COPY_KEYLEN_TYPE I32
1590 #else
1591 # define VMG_SVT_COPY_KEYLEN_TYPE int
1592 #endif
1593
1594 /* ... copy magic .......................................................... */
1595
1596 static int vmg_svt_copy(pTHX_ SV *sv, MAGIC *mg, SV *nsv, const char *key, VMG_SVT_COPY_KEYLEN_TYPE keylen) {
1597  const vmg_wizard *w = vmg_wizard_from_mg_nocheck(mg);
1598  SV *keysv;
1599  int ret;
1600
1601  if (keylen == HEf_SVKEY) {
1602   keysv = (SV *) key;
1603  } else {
1604   keysv = newSVpvn(key, keylen);
1605  }
1606
1607  if (SvTYPE(sv) >= SVt_PVCV)
1608   nsv = sv_2mortal(newRV_inc(nsv));
1609
1610  ret = vmg_cb_call3(w->cb_copy, w->opinfo, sv, mg->mg_obj, keysv, nsv);
1611
1612  if (keylen != HEf_SVKEY) {
1613   SvREFCNT_dec(keysv);
1614  }
1615
1616  return ret;
1617 }
1618
1619 static int vmg_svt_copy_noop(pTHX_ SV *sv, MAGIC *mg, SV *nsv, const char *key, VMG_SVT_COPY_KEYLEN_TYPE keylen) {
1620  return 0;
1621 }
1622
1623 /* ... dup magic ........................................................... */
1624
1625 #if 0
1626 static int vmg_svt_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) {
1627  return 0;
1628 }
1629 #define vmg_svt_dup_noop vmg_svt_dup
1630 #endif
1631
1632 /* ... local magic ......................................................... */
1633
1634 #if MGf_LOCAL
1635
1636 static int vmg_svt_local(pTHX_ SV *nsv, MAGIC *mg) {
1637  const vmg_wizard *w = vmg_wizard_from_mg_nocheck(mg);
1638
1639  return vmg_cb_call1(w->cb_local, w->opinfo, nsv, mg->mg_obj);
1640 }
1641
1642 #define vmg_svt_local_noop vmg_svt_default_noop
1643
1644 #endif /* MGf_LOCAL */
1645
1646 /* ... uvar magic .......................................................... */
1647
1648 #if VMG_UVAR
1649
1650 static OP *vmg_pp_reset_rmg(pTHX) {
1651  SVOP *o = cSVOPx(PL_op);
1652
1653  SvRMAGICAL_on(o->op_sv);
1654  o->op_sv = NULL;
1655
1656  return NORMAL;
1657 }
1658
1659 static I32 vmg_svt_val(pTHX_ IV action, SV *sv) {
1660  vmg_uvar_ud *ud;
1661  MAGIC *mg, *umg, *moremagic;
1662  SV *key = NULL, *newkey = NULL;
1663  int tied = 0;
1664
1665  umg = mg_find(sv, PERL_MAGIC_uvar);
1666  /* umg can't be NULL or we wouldn't be there. */
1667  key = umg->mg_obj;
1668  ud  = (vmg_uvar_ud *) umg->mg_ptr;
1669
1670  if (ud->old_uf.uf_val)
1671   ud->old_uf.uf_val(aTHX_ action, sv);
1672  if (ud->old_uf.uf_set)
1673   ud->old_uf.uf_set(aTHX_ action, sv);
1674
1675  for (mg = SvMAGIC(sv); mg; mg = moremagic) {
1676   const vmg_wizard *w;
1677
1678   /* mg may be freed later by the uvar call, so we need to fetch the next
1679    * token before reaching that fateful point. */
1680   moremagic = mg->mg_moremagic;
1681
1682   switch (mg->mg_type) {
1683    case PERL_MAGIC_ext:
1684     break;
1685    case PERL_MAGIC_tied:
1686     ++tied;
1687     continue;
1688    default:
1689     continue;
1690   }
1691
1692   w = vmg_wizard_from_mg(mg);
1693   if (!w)
1694    continue;
1695
1696   switch (w->uvar) {
1697    case 0:
1698     continue;
1699    case 2:
1700     if (!newkey)
1701      newkey = key = umg->mg_obj = sv_mortalcopy(umg->mg_obj);
1702   }
1703
1704   switch (action
1705              & (HV_FETCH_ISSTORE|HV_FETCH_ISEXISTS|HV_FETCH_LVALUE|HV_DELETE)) {
1706    case 0:
1707     if (w->cb_fetch)
1708      vmg_cb_call2(w->cb_fetch, w->opinfo | VMG_CB_CALL_GUARD, sv,
1709                                mg->mg_obj, key);
1710     break;
1711    case HV_FETCH_ISSTORE:
1712    case HV_FETCH_LVALUE:
1713    case (HV_FETCH_ISSTORE|HV_FETCH_LVALUE):
1714     if (w->cb_store)
1715      vmg_cb_call2(w->cb_store, w->opinfo | VMG_CB_CALL_GUARD, sv,
1716                                mg->mg_obj, key);
1717     break;
1718    case HV_FETCH_ISEXISTS:
1719     if (w->cb_exists)
1720      vmg_cb_call2(w->cb_exists, w->opinfo | VMG_CB_CALL_GUARD, sv,
1721                                 mg->mg_obj, key);
1722     break;
1723    case HV_DELETE:
1724     if (w->cb_delete)
1725      vmg_cb_call2(w->cb_delete, w->opinfo | VMG_CB_CALL_GUARD, sv,
1726                                 mg->mg_obj, key);
1727     break;
1728   }
1729  }
1730
1731  if (SvRMAGICAL(sv) && !tied && !(action & (HV_FETCH_ISSTORE|HV_DELETE))) {
1732   /* Temporarily hide the RMAGICAL flag of the hash so it isn't wrongly
1733    * mistaken for a tied hash by the rest of hv_common. It will be reset by
1734    * the op_ppaddr of a new fake op injected between the current and the next
1735    * one. */
1736
1737 #if VMG_RESET_RMG_NEEDS_TRAMPOLINE
1738
1739   dMY_CXT;
1740
1741   PL_op = vmg_trampoline_bump(&MY_CXT.reset_rmg, sv, PL_op);
1742
1743 #else /* !VMG_RESET_RMG_NEEDS_TRAMPOLINE */
1744
1745   OP   *nop  = PL_op->op_next;
1746   SVOP *svop = NULL;
1747
1748   if (nop && nop->op_ppaddr == vmg_pp_reset_rmg) {
1749    svop = (SVOP *) nop;
1750   } else {
1751    NewOp(1101, svop, 1, SVOP);
1752    svop->op_type    = OP_STUB;
1753    svop->op_ppaddr  = vmg_pp_reset_rmg;
1754    svop->op_next    = nop;
1755    svop->op_flags   = 0;
1756    svop->op_private = 0;
1757
1758    PL_op->op_next = (OP *) svop;
1759   }
1760
1761   svop->op_sv = sv;
1762
1763 #endif /* VMG_RESET_RMG_NEEDS_TRAMPOLINE */
1764
1765   SvRMAGICAL_off(sv);
1766  }
1767
1768  return 0;
1769 }
1770
1771 #endif /* VMG_UVAR */
1772
1773 /* --- Module setup/teardown ----------------------------------------------- */
1774
1775 #if VMG_THREADSAFE
1776
1777 static I32 vmg_loaded = 0;
1778
1779 /* We must use preexistent global mutexes or we will never be able to destroy
1780  * them. */
1781 # if VMG_HAS_PERL(5, 9, 3)
1782 #  define VMG_LOADED_LOCK   MUTEX_LOCK(&PL_my_ctx_mutex)
1783 #  define VMG_LOADED_UNLOCK MUTEX_UNLOCK(&PL_my_ctx_mutex)
1784 # else
1785 #  define VMG_LOADED_LOCK   OP_REFCNT_LOCK
1786 #  define VMG_LOADED_UNLOCK OP_REFCNT_UNLOCK
1787 # endif
1788
1789 static void vmg_global_teardown_late_locked(pTHX) {
1790 #define vmg_global_teardown_late_locked() vmg_global_teardown_late_locked(aTHX)
1791  MUTEX_DESTROY(&vmg_op_name_init_mutex);
1792  MUTEX_DESTROY(&vmg_vtable_refcount_mutex);
1793
1794  return;
1795 }
1796
1797 static int vmg_global_teardown_free(pTHX_ SV *sv, MAGIC *mg) {
1798  VMG_LOADED_LOCK;
1799
1800  if (vmg_loaded == 0)
1801   vmg_global_teardown_late_locked();
1802
1803  VMG_LOADED_UNLOCK;
1804
1805  return 0;
1806 }
1807
1808 static MGVTBL vmg_global_teardown_vtbl = {
1809  0,
1810  0,
1811  0,
1812  0,
1813  vmg_global_teardown_free
1814 #if MGf_COPY
1815  , 0
1816 #endif
1817 #if MGf_DUP
1818  , 0
1819 #endif
1820 #if MGf_LOCAL
1821  , 0
1822 #endif
1823 };
1824
1825 static signed char vmg_destruct_level(pTHX) {
1826 #define vmg_destruct_level() vmg_destruct_level(aTHX)
1827  signed char lvl;
1828
1829  lvl = PL_perl_destruct_level;
1830
1831 #ifdef DEBUGGING
1832  {
1833   const char *s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL");
1834   if (s) {
1835    int i;
1836 #if VMG_HAS_PERL(5, 21, 3)
1837    if (strEQ(s, "-1")) {
1838     i = -1;
1839    } else {
1840 # if VMG_HAS_PERL(5, 21, 10)
1841     UV uv;
1842     if (Perl_grok_atoUV(s, &uv, NULL) && uv <= INT_MAX)
1843      i = (int) uv;
1844     else
1845      i = 0;
1846 # else /* VMG_HAS_PERL(5, 21, 3) && !VMG_HAS_PERL(5, 21, 10) */
1847     i = Perl_grok_atou(s, NULL);
1848 # endif
1849    }
1850 #else /* !VMG_HAS_PERL(5, 21, 3) */
1851    i = atoi(s);
1852 #endif
1853    if (lvl < i)
1854     lvl = i;
1855   }
1856  }
1857 #endif
1858
1859  return lvl;
1860 }
1861
1862 #endif /* VMG_THREADSAFE */
1863
1864 static void vmg_teardown(pTHX_ void *param) {
1865  dMY_CXT;
1866
1867 #if VMG_THREADSAFE
1868  VMG_LOADED_LOCK;
1869
1870  if (vmg_loaded == 1) {
1871   vmg_loaded = 0;
1872   if (vmg_destruct_level() == 0) {
1873    vmg_global_teardown_late_locked();
1874   } else {
1875    if (!PL_strtab)
1876     PL_strtab = newHV();
1877    vmg_sv_magicext((SV *) PL_strtab, NULL, &vmg_global_teardown_vtbl, NULL, 0);
1878   }
1879  } else {
1880   VMG_ASSERT(vmg_loaded > 1);
1881   --vmg_loaded;
1882  }
1883
1884  VMG_LOADED_UNLOCK;
1885 #endif
1886
1887  if (MY_CXT.depth == 0 && MY_CXT.freed_tokens) {
1888   vmg_magic_chain_free(MY_CXT.freed_tokens, NULL);
1889   MY_CXT.freed_tokens = NULL;
1890  }
1891
1892  return;
1893 }
1894
1895 static void vmg_setup(pTHX) {
1896 #define vmg_setup() vmg_setup(aTHX)
1897  HV *stash;
1898  int c;
1899  MY_CXT_INIT;
1900
1901 #if VMG_THREADSAFE
1902  VMG_LOADED_LOCK;
1903
1904  if (vmg_loaded == 0) {
1905   MUTEX_INIT(&vmg_vtable_refcount_mutex);
1906   MUTEX_INIT(&vmg_op_name_init_mutex);
1907   vmg_loaded = 1;
1908  } else {
1909   VMG_ASSERT(vmg_loaded > 0);
1910   ++vmg_loaded;
1911  }
1912
1913  VMG_LOADED_UNLOCK;
1914 #endif
1915
1916  for (c = OPc_NULL; c < OPc_MAX; ++c)
1917   MY_CXT.b__op_stashes[c] = NULL;
1918
1919  MY_CXT.depth        = 0;
1920  MY_CXT.freed_tokens = NULL;
1921
1922 #if VMG_PROPAGATE_ERRSV_NEEDS_TRAMPOLINE
1923  vmg_trampoline_init(&MY_CXT.propagate_errsv, vmg_pp_propagate_errsv);
1924 #endif
1925 #if VMG_RESET_RMG_NEEDS_TRAMPOLINE
1926  vmg_trampoline_init(&MY_CXT.reset_rmg, vmg_pp_reset_rmg);
1927 #endif
1928
1929  stash = gv_stashpv(__PACKAGE__, 1);
1930  newCONSTSUB(stash, "MGf_COPY",  newSVuv(MGf_COPY));
1931  newCONSTSUB(stash, "MGf_DUP",   newSVuv(MGf_DUP));
1932  newCONSTSUB(stash, "MGf_LOCAL", newSVuv(MGf_LOCAL));
1933  newCONSTSUB(stash, "VMG_UVAR",  newSVuv(VMG_UVAR));
1934  newCONSTSUB(stash, "VMG_COMPAT_SCALAR_LENGTH_NOLEN",
1935                     newSVuv(VMG_COMPAT_SCALAR_LENGTH_NOLEN));
1936  newCONSTSUB(stash, "VMG_COMPAT_SCALAR_NOLEN",
1937                     newSVuv(VMG_COMPAT_SCALAR_NOLEN));
1938  newCONSTSUB(stash, "VMG_COMPAT_ARRAY_PUSH_NOLEN",
1939                     newSVuv(VMG_COMPAT_ARRAY_PUSH_NOLEN));
1940  newCONSTSUB(stash, "VMG_COMPAT_ARRAY_PUSH_NOLEN_VOID",
1941                     newSVuv(VMG_COMPAT_ARRAY_PUSH_NOLEN_VOID));
1942  newCONSTSUB(stash, "VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID",
1943                     newSVuv(VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID));
1944  newCONSTSUB(stash, "VMG_COMPAT_ARRAY_UNDEF_CLEAR",
1945                     newSVuv(VMG_COMPAT_ARRAY_UNDEF_CLEAR));
1946  newCONSTSUB(stash, "VMG_COMPAT_HASH_DELETE_NOUVAR_VOID",
1947                     newSVuv(VMG_COMPAT_HASH_DELETE_NOUVAR_VOID));
1948  newCONSTSUB(stash, "VMG_COMPAT_CODE_COPY_CLONE",
1949                     newSVuv(VMG_COMPAT_CODE_COPY_CLONE));
1950  newCONSTSUB(stash, "VMG_COMPAT_GLOB_GET", newSVuv(VMG_COMPAT_GLOB_GET));
1951  newCONSTSUB(stash, "VMG_PERL_PATCHLEVEL", newSVuv(VMG_PERL_PATCHLEVEL));
1952  newCONSTSUB(stash, "VMG_THREADSAFE",      newSVuv(VMG_THREADSAFE));
1953  newCONSTSUB(stash, "VMG_FORKSAFE",        newSVuv(VMG_FORKSAFE));
1954  newCONSTSUB(stash, "VMG_OP_INFO_NAME",    newSVuv(VMG_OP_INFO_NAME));
1955  newCONSTSUB(stash, "VMG_OP_INFO_OBJECT",  newSVuv(VMG_OP_INFO_OBJECT));
1956
1957  call_atexit(vmg_teardown, NULL);
1958
1959  return;
1960 }
1961
1962 /* --- Macros for the XS section ------------------------------------------- */
1963
1964 #ifdef CvISXSUB
1965 # define VMG_CVOK(C) \
1966    ((CvISXSUB(C) ? (void *) CvXSUB(C) : (void *) CvROOT(C)) ? 1 : 0)
1967 #else
1968 # define VMG_CVOK(C) (CvROOT(C) || CvXSUB(C))
1969 #endif
1970
1971 #define VMG_CBOK(S) ((SvTYPE(S) == SVt_PVCV) ? VMG_CVOK(S) : SvOK(S))
1972
1973 #define VMG_SET_CB(S, N) {       \
1974  SV *cb = (S);                   \
1975  if (SvOK(cb) && SvROK(cb)) {    \
1976   cb = SvRV(cb);                 \
1977   if (VMG_CBOK(cb))              \
1978    SvREFCNT_inc_simple_void(cb); \
1979   else                           \
1980    cb = NULL;                    \
1981  } else {                        \
1982   cb = NULL;                     \
1983  }                               \
1984  w->cb_ ## N = cb;               \
1985 }
1986
1987 #define VMG_SET_SVT_CB(S, N) {   \
1988  SV *cb = (S);                   \
1989  if (SvOK(cb) && SvROK(cb)) {    \
1990   cb = SvRV(cb);                 \
1991   if (VMG_CBOK(cb)) {            \
1992    t->svt_ ## N = vmg_svt_ ## N; \
1993    SvREFCNT_inc_simple_void(cb); \
1994   } else {                       \
1995    t->svt_ ## N = vmg_svt_ ## N ## _noop; \
1996    cb           = NULL;          \
1997   }                              \
1998  } else {                        \
1999   t->svt_ ## N = NULL;           \
2000   cb           = NULL;           \
2001  }                               \
2002  w->cb_ ## N = cb;               \
2003 }
2004
2005 /* --- XS ------------------------------------------------------------------ */
2006
2007 MODULE = Variable::Magic            PACKAGE = Variable::Magic
2008
2009 PROTOTYPES: ENABLE
2010
2011 BOOT:
2012 {
2013  vmg_setup();
2014 }
2015
2016 #if VMG_THREADSAFE
2017
2018 void
2019 CLONE(...)
2020 PROTOTYPE: DISABLE
2021 PREINIT:
2022  U32 had_b__op_stash = 0;
2023  I32 old_depth;
2024  int c;
2025 PPCODE:
2026  {
2027   dMY_CXT;
2028   for (c = OPc_NULL; c < OPc_MAX; ++c) {
2029    if (MY_CXT.b__op_stashes[c])
2030     had_b__op_stash |= (((U32) 1) << c);
2031   }
2032   old_depth = MY_CXT.depth;
2033  }
2034  {
2035   MY_CXT_CLONE;
2036   for (c = OPc_NULL; c < OPc_MAX; ++c) {
2037    MY_CXT.b__op_stashes[c] = (had_b__op_stash & (((U32) 1) << c))
2038                               ? gv_stashpv(vmg_opclassnames[c], 1) : NULL;
2039   }
2040   MY_CXT.depth        = old_depth;
2041   MY_CXT.freed_tokens = NULL;
2042   VMG_LOADED_LOCK;
2043   VMG_ASSERT(vmg_loaded > 0);
2044   ++vmg_loaded;
2045   VMG_LOADED_UNLOCK;
2046  }
2047  XSRETURN(0);
2048
2049 #endif /* VMG_THREADSAFE */
2050
2051 SV *_wizard(...)
2052 PROTOTYPE: DISABLE
2053 PREINIT:
2054  vmg_wizard *w;
2055  MGVTBL *t;
2056  SV *op_info, *copy_key;
2057  I32 i = 0;
2058 CODE:
2059  if (items != 9
2060 #if MGf_LOCAL
2061               + 1
2062 #endif /* MGf_LOCAL */
2063 #if VMG_UVAR
2064               + 5
2065 #endif /* VMG_UVAR */
2066               ) { croak(vmg_wrongargnum); }
2067
2068  op_info = ST(i++);
2069  w = vmg_wizard_alloc(SvOK(op_info) ? SvUV(op_info) : 0);
2070  t = vmg_vtable_vtbl(w->vtable);
2071
2072  VMG_SET_CB(ST(i++), data);
2073
2074  VMG_SET_SVT_CB(ST(i++), get);
2075  VMG_SET_SVT_CB(ST(i++), set);
2076  VMG_SET_SVT_CB(ST(i++), len);
2077  VMG_SET_SVT_CB(ST(i++), clear);
2078  VMG_SET_SVT_CB(ST(i++), free);
2079  VMG_SET_SVT_CB(ST(i++), copy);
2080  /* VMG_SET_SVT_CB(ST(i++), dup); */
2081  i++;
2082  t->svt_dup = NULL;
2083  w->cb_dup  = NULL;
2084 #if MGf_LOCAL
2085  VMG_SET_SVT_CB(ST(i++), local);
2086 #endif /* MGf_LOCAL */
2087 #if VMG_UVAR
2088  VMG_SET_CB(ST(i++), fetch);
2089  VMG_SET_CB(ST(i++), store);
2090  VMG_SET_CB(ST(i++), exists);
2091  VMG_SET_CB(ST(i++), delete);
2092
2093  copy_key = ST(i++);
2094  if (w->cb_fetch || w->cb_store || w->cb_exists || w->cb_delete)
2095   w->uvar = SvTRUE(copy_key) ? 2 : 1;
2096 #endif /* VMG_UVAR */
2097
2098  RETVAL = newRV_noinc(vmg_wizard_sv_new(w));
2099 OUTPUT:
2100  RETVAL
2101
2102 SV *cast(SV *sv, SV *wiz, ...)
2103 PROTOTYPE: \[$@%&*]$@
2104 PREINIT:
2105  const vmg_wizard *w = NULL;
2106  SV **args = NULL;
2107  I32 i = 0;
2108 CODE:
2109  if (items > 2) {
2110   i = items - 2;
2111   args = &ST(2);
2112  }
2113  if (SvROK(wiz)) {
2114   wiz = SvRV_const(wiz);
2115   w   = vmg_wizard_from_sv(wiz);
2116  }
2117  if (!w)
2118   croak(vmg_invalid_wiz);
2119  RETVAL = newSVuv(vmg_cast(SvRV(sv), w, wiz, args, i));
2120 OUTPUT:
2121  RETVAL
2122
2123 void
2124 getdata(SV *sv, SV *wiz)
2125 PROTOTYPE: \[$@%&*]$
2126 PREINIT:
2127  const vmg_wizard *w = NULL;
2128  SV *data;
2129 PPCODE:
2130  if (SvROK(wiz))
2131   w = vmg_wizard_from_sv(SvRV_const(wiz));
2132  if (!w)
2133   croak(vmg_invalid_wiz);
2134  data = vmg_data_get(SvRV(sv), w);
2135  if (!data)
2136   XSRETURN_EMPTY;
2137  ST(0) = data;
2138  XSRETURN(1);
2139
2140 SV *dispell(SV *sv, SV *wiz)
2141 PROTOTYPE: \[$@%&*]$
2142 PREINIT:
2143  const vmg_wizard *w = NULL;
2144 CODE:
2145  if (SvROK(wiz))
2146   w = vmg_wizard_from_sv(SvRV_const(wiz));
2147  if (!w)
2148   croak(vmg_invalid_wiz);
2149  RETVAL = newSVuv(vmg_dispell(SvRV(sv), w));
2150 OUTPUT:
2151  RETVAL