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