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