autovivification.xs

   1 /* This file is part of the autovivification Perl module.
   2  * See http://search.cpan.org/dist/autovivification/ */
   3
   4 #define PERL_NO_GET_CONTEXT
   5 #include "EXTERN.h"
   6 #include "perl.h"
   7 #include "XSUB.h"
   8
   9 #define __PACKAGE__     "autovivification"
  10 #define __PACKAGE_LEN__ (sizeof(__PACKAGE__)-1)
  11
  12 /* --- Compatibility wrappers ---------------------------------------------- */
  13
  14 #define A_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
  15
  16 #ifndef A_WORKAROUND_REQUIRE_PROPAGATION
  17 # define A_WORKAROUND_REQUIRE_PROPAGATION !A_HAS_PERL(5, 10, 1)
  18 #endif
  19
  20 /* --- Helpers ------------------------------------------------------------- */
  21
  22 #if A_WORKAROUND_REQUIRE_PROPAGATION
  23
  24 #define A_ENCODE_UV(B, U)   \
  25  len = 0;                   \
  26  while (len < sizeof(UV)) { \
  27   (B)[len++] = (U) & 0xFF;  \
  28   (U) >>= 8;                \
  29  }
  30
  31 #define A_DECODE_UV(U, B)        \
  32  len = sizeof(UV);               \
  33  while (len > 0)                 \
  34   (U) = ((U) << 8) | (B)[--len];
  35
  36 STATIC SV *a_tag(pTHX_ UV bits) {
  37 #define a_tag(B) a_tag(aTHX_ (B))
  38  SV            *hint;
  39  const PERL_SI *si;
  40  UV             requires = 0;
  41  unsigned char  buf[sizeof(UV) * 2];
  42  STRLEN         len;
  43
  44  for (si = PL_curstackinfo; si; si = si->si_prev) {
  45   I32 cxix;
  46
  47   for (cxix = si->si_cxix; cxix >= 0; --cxix) {
  48    const PERL_CONTEXT *cx = si->si_cxstack + cxix;
  49
  50    if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_REQUIRE)
  51     ++requires;
  52   }
  53  }
  54
  55  A_ENCODE_UV(buf,              requires);
  56  A_ENCODE_UV(buf + sizeof(UV), bits);
  57  hint = newSVpvn(buf, sizeof buf);
  58  SvREADONLY_on(hint);
  59
  60  return hint;
  61 }
  62
  63 STATIC UV a_detag(pTHX_ const SV *hint) {
  64 #define a_detag(H) a_detag(aTHX_ (H))
  65  const PERL_SI *si;
  66  UV             requires = 0, requires_max = 0, bits = 0;
  67  unsigned char *buf;
  68  STRLEN         len;
  69
  70  if (!(hint && SvOK(hint)))
  71   return 0;
  72
  73  buf = SvPVX(hint);
  74  A_DECODE_UV(requires_max, buf);
  75
  76  for (si = PL_curstackinfo; si; si = si->si_prev) {
  77   I32 cxix;
  78
  79   for (cxix = si->si_cxix; cxix >= 0; --cxix) {
  80    const PERL_CONTEXT *cx = si->si_cxstack + cxix;
  81
  82    if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_REQUIRE
  83                               && ++requires > requires_max)
  84     return 0;
  85   }
  86  }
  87
  88  A_DECODE_UV(bits, buf + sizeof(UV));
  89
  90  return bits;
  91 }
  92
  93 #else /* A_WORKAROUND_REQUIRE_PROPAGATION */
  94
  95 #define a_tag(B)   newSVuv(B)
  96 #define a_detag(H) (((H) && SvOK(H)) ? SvUVX(H) : 0)
  97
  98 #endif /* !A_WORKAROUND_REQUIRE_PROPAGATION */
  99
 100 /* Used both for hints and op flags */
 101 #define A_HINT_STRICT 1
 102 #define A_HINT_WARN   2
 103 #define A_HINT_FETCH  4
 104 #define A_HINT_STORE  8
 105 #define A_HINT_EXISTS 16
 106 #define A_HINT_DELETE 32
 107 #define A_HINT_NOTIFY (A_HINT_STRICT|A_HINT_WARN)
 108 #define A_HINT_DO     (A_HINT_FETCH|A_HINT_STORE|A_HINT_EXISTS|A_HINT_DELETE)
 109 #define A_HINT_MASK   (A_HINT_NOTIFY|A_HINT_DO)
 110
 111 /* Only used in op flags */
 112 #define A_HINT_DEREF  64
 113
 114 STATIC U32 a_hash = 0;
 115
 116 STATIC UV a_hint(pTHX) {
 117 #define a_hint() a_hint(aTHX)
 118  SV *hint;
 119 #if A_HAS_PERL(5, 9, 5)
 120  hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
 121                                        NULL,
 122                                        __PACKAGE__, __PACKAGE_LEN__,
 123                                        0,
 124                                        a_hash);
 125 #else
 126  SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__, a_hash);
 127  if (!val)
 128   return 0;
 129  hint = *val;
 130 #endif
 131  return a_detag(hint);
 132 }
 133
 134 /* ... op => info map ...................................................... */
 135
 136 typedef struct {
 137  OP *(*old_pp)(pTHX);
 138  const OP *root;
 139  UV flags;
 140 } a_op_info;
 141
 142 #define PTABLE_NAME        ptable_map
 143 #define PTABLE_VAL_FREE(V) PerlMemShared_free(V)
 144
 145 #include "ptable.h"
 146
 147 /* PerlMemShared_free() needs the [ap]PTBLMS_? default values */
 148 #define ptable_map_store(T, K, V) ptable_map_store(aPTBLMS_ (T), (K), (V))
 149
 150 STATIC ptable *a_op_map = NULL;
 151
 152 #ifdef USE_ITHREADS
 153 STATIC perl_mutex a_op_map_mutex;
 154 #endif
 155
 156 STATIC void a_map_store(pPTBLMS_ const OP *o, OP *(*old_pp)(pTHX), UV flags) {
 157 #define a_map_store(O, PP, F) a_map_store(aPTBLMS_ (O), (PP), (F))
 158  a_op_info *oi;
 159
 160 #ifdef USE_ITHREADS
 161  MUTEX_LOCK(&a_op_map_mutex);
 162 #endif
 163
 164  if (!(oi = ptable_fetch(a_op_map, o))) {
 165   oi = PerlMemShared_malloc(sizeof *oi);
 166   ptable_map_store(a_op_map, o, oi);
 167  }
 168
 169  oi->old_pp = old_pp;
 170  oi->root   = NULL;
 171  oi->flags  = flags;
 172
 173 #ifdef USE_ITHREADS
 174  MUTEX_UNLOCK(&a_op_map_mutex);
 175 #endif
 176 }
 177
 178 STATIC const a_op_info *a_map_fetch(const OP *o, a_op_info *oi) {
 179  const a_op_info *val;
 180
 181 #ifdef USE_ITHREADS
 182  MUTEX_LOCK(&a_op_map_mutex);
 183 #endif
 184
 185  val = ptable_fetch(a_op_map, o);
 186  *oi = *val;
 187
 188 #ifdef USE_ITHREADS
 189  MUTEX_UNLOCK(&a_op_map_mutex);
 190 #endif
 191
 192  return val;
 193 }
 194
 195 STATIC void a_map_delete(pTHX_ const OP *o) {
 196 #define a_map_delete(O) a_map_delete(aTHX_ (O))
 197 #ifdef USE_ITHREADS
 198  MUTEX_LOCK(&a_op_map_mutex);
 199 #endif
 200
 201  ptable_map_store(a_op_map, o, NULL);
 202
 203 #ifdef USE_ITHREADS
 204  MUTEX_UNLOCK(&a_op_map_mutex);
 205 #endif
 206 }
 207
 208 STATIC void a_map_set_root(const OP *root, UV flags) {
 209  a_op_info *oi;
 210  const OP *o = root;
 211
 212 #ifdef USE_ITHREADS
 213  MUTEX_LOCK(&a_op_map_mutex);
 214 #endif
 215
 216  while (o) {
 217   if (oi = ptable_fetch(a_op_map, o)) {
 218    oi->root  = root;
 219    oi->flags = flags;
 220   }
 221   if (!(o->op_flags & OPf_KIDS))
 222    break;
 223   switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
 224    case OA_BASEOP:
 225    case OA_UNOP:
 226    case OA_BINOP:
 227    case OA_BASEOP_OR_UNOP:
 228     o = cUNOPo->op_first;
 229     break;
 230    case OA_LIST:
 231    case OA_LISTOP:
 232     o = cLISTOPo->op_last;
 233     break;
 234    default:
 235     goto done;
 236   }
 237  }
 238
 239 done:
 240 #ifdef USE_ITHREADS
 241  MUTEX_UNLOCK(&a_op_map_mutex);
 242 #endif
 243
 244  return;
 245 }
 246
 247 /* ... Lightweight pp_defined() ............................................ */
 248
 249 STATIC bool a_defined(pTHX_ SV *sv) {
 250 #define a_defined(S) a_defined(aTHX_ (S))
 251  bool defined = FALSE;
 252
 253  switch (SvTYPE(sv)) {
 254   case SVt_PVAV:
 255    if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
 256                       || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
 257     defined = TRUE;
 258    break;
 259   case SVt_PVHV:
 260    if (HvARRAY(sv) || SvGMAGICAL(sv)
 261                    || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
 262     defined = TRUE;
 263    break;
 264   default:
 265    defined = SvOK(sv);
 266  }
 267
 268  return defined;
 269 }
 270
 271 /* --- PP functions -------------------------------------------------------- */
 272
 273 /* ... pp_rv2av ............................................................ */
 274
 275 STATIC OP *a_pp_rv2av(pTHX) {
 276  a_op_info oi;
 277  UV hint;
 278  dSP;
 279
 280  a_map_fetch(PL_op, &oi);
 281
 282  if (PL_op == oi.root) { /* This means "@$arrayref" */
 283   PL_op->op_ppaddr = oi.old_pp;
 284  } else if (!SvOK(TOPs)) {
 285   /* We always need to push an empty array to fool the pp_aelem() that comes
 286    * later. */
 287   SV *av;
 288   POPs;
 289   av = sv_2mortal((SV *) newAV());
 290   PUSHs(av);
 291   RETURN;
 292  }
 293
 294  return CALL_FPTR(oi.old_pp)(aTHX);
 295 }
 296
 297 /* ... pp_rv2hv ............................................................ */
 298
 299 STATIC OP *a_pp_rv2hv(pTHX) {
 300  a_op_info oi;
 301  UV hint;
 302  dSP;
 303
 304  a_map_fetch(PL_op, &oi);
 305
 306  if (PL_op == oi.root) { /* This means "%$hashref" */
 307   PL_op->op_ppaddr = oi.old_pp;
 308  } else if (!SvOK(TOPs)) {
 309   RETURN;
 310  }
 311
 312  return CALL_FPTR(oi.old_pp)(aTHX);
 313 }
 314
 315 /* ... pp_deref (aelem,helem,rv2sv,padsv) .................................. */
 316
 317 STATIC OP *a_pp_deref(pTHX) {
 318  a_op_info oi;
 319  UV flags;
 320  dSP;
 321
 322  a_map_fetch(PL_op, &oi);
 323  flags = oi.flags;
 324
 325  if (flags & A_HINT_DEREF) {
 326   OP *o;
 327   U8 old_private;
 328
 329 deref:
 330   old_private       = PL_op->op_private;
 331   PL_op->op_private = ((old_private & ~OPpDEREF) | OPpLVAL_DEFER);
 332   o = CALL_FPTR(oi.old_pp)(aTHX);
 333   PL_op->op_private = old_private;
 334
 335   if (flags & (A_HINT_NOTIFY|A_HINT_STORE)) {
 336    SPAGAIN;
 337    if (!SvOK(TOPs)) {
 338     if (flags & A_HINT_STRICT)
 339      croak("Reference vivification forbidden");
 340     else if (flags & A_HINT_WARN)
 341       warn("Reference was vivified");
 342     else /* A_HINT_STORE */
 343      croak("Can't vivify reference");
 344    }
 345   }
 346
 347   return o;
 348  } else if (flags && (PL_op->op_private & OPpDEREF || PL_op == oi.root)) {
 349   oi.flags = flags & A_HINT_NOTIFY;
 350
 351   if (oi.root->op_flags & OPf_MOD) {
 352    if (flags & A_HINT_STORE)
 353     oi.flags |= (A_HINT_STORE|A_HINT_DEREF);
 354   } else if (flags & A_HINT_FETCH)
 355     oi.flags |= (A_HINT_FETCH|A_HINT_DEREF);
 356
 357   if (PL_op == oi.root)
 358    oi.flags &= ~A_HINT_DEREF;
 359
 360   /* We will need the updated flags value in the deref part */
 361   flags = oi.flags;
 362
 363   if (flags & A_HINT_DEREF)
 364    goto deref;
 365
 366   /* This op doesn't need to skip autovivification, so restore the original
 367    * state. Be aware that another extension might have saved a_pp_deref as the
 368    * ppaddr for this op, so restoring PL_op->op_ppaddr doesn't ensure that this
 369    * function will never be called again. That's why we don't remove the op info
 370    * from our map and we reset oi.flags to 0, so that it can still run correctly
 371    * if required. */
 372   oi.flags = 0;
 373   PL_op->op_ppaddr = oi.old_pp;
 374  }
 375
 376  return CALL_FPTR(oi.old_pp)(aTHX);
 377 }
 378
 379 /* ... pp_root (exists,delete,keys,values) ................................. */
 380
 381 STATIC OP *a_pp_root_unop(pTHX) {
 382  a_op_info oi;
 383  dSP;
 384
 385  if (!a_defined(TOPs)) {
 386   POPs;
 387   /* Can only be reached by keys or values */
 388   if (GIMME_V == G_SCALAR) {
 389    dTARGET;
 390    PUSHi(0);
 391   }
 392   RETURN;
 393  }
 394
 395  a_map_fetch(PL_op, &oi);
 396
 397  return CALL_FPTR(oi.old_pp)(aTHX);
 398 }
 399
 400 STATIC OP *a_pp_root_binop(pTHX) {
 401  a_op_info oi;
 402  dSP;
 403
 404  if (!a_defined(TOPm1s)) {
 405   POPs;
 406   POPs;
 407   if (PL_op->op_type == OP_EXISTS)
 408    RETPUSHNO;
 409   else
 410    RETPUSHUNDEF;
 411  }
 412
 413  a_map_fetch(PL_op, &oi);
 414
 415  return CALL_FPTR(oi.old_pp)(aTHX);
 416 }
 417
 418 /* --- Check functions ----------------------------------------------------- */
 419
 420 /* ... ck_pad{any,sv} ...................................................... */
 421
 422 /* Sadly, the PADSV OPs we are interested in don't trigger the padsv check
 423  * function, but are instead manually mutated from a PADANY. This is why we set
 424  * PL_ppaddr[OP_PADSV] in the padany check function so that PADSV OPs will have
 425  * their op_ppaddr set to our pp_padsv. PL_ppaddr[OP_PADSV] is then reset at the
 426  * beginning of every ck_pad{any,sv}. Some unwanted OPs can still call our
 427  * pp_padsv, but much less than if we would have set PL_ppaddr[OP_PADSV]
 428  * globally. */
 429
 430 STATIC OP *(*a_pp_padsv_saved)(pTHX) = 0;
 431
 432 STATIC void a_pp_padsv_save(void) {
 433  if (a_pp_padsv_saved)
 434   return;
 435
 436  a_pp_padsv_saved    = PL_ppaddr[OP_PADSV];
 437  PL_ppaddr[OP_PADSV] = a_pp_deref;
 438 }
 439
 440 STATIC void a_pp_padsv_restore(OP *o) {
 441  if (!a_pp_padsv_saved)
 442   return;
 443
 444  if (o->op_ppaddr == a_pp_deref)
 445   o->op_ppaddr = a_pp_padsv_saved;
 446
 447  PL_ppaddr[OP_PADSV] = a_pp_padsv_saved;
 448  a_pp_padsv_saved    = 0;
 449 }
 450
 451 STATIC OP *(*a_old_ck_padany)(pTHX_ OP *) = 0;
 452
 453 STATIC OP *a_ck_padany(pTHX_ OP *o) {
 454  UV hint;
 455
 456  a_pp_padsv_restore(o);
 457
 458  o = CALL_FPTR(a_old_ck_padany)(aTHX_ o);
 459
 460  hint = a_hint();
 461  if (hint & A_HINT_DO) {
 462   a_pp_padsv_save();
 463   a_map_store(o, a_pp_padsv_saved, hint);
 464  } else
 465   a_map_delete(o);
 466
 467  return o;
 468 }
 469
 470 STATIC OP *(*a_old_ck_padsv)(pTHX_ OP *) = 0;
 471
 472 STATIC OP *a_ck_padsv(pTHX_ OP *o) {
 473  UV hint;
 474
 475  a_pp_padsv_restore(o);
 476
 477  o = CALL_FPTR(a_old_ck_padsv)(aTHX_ o);
 478
 479  hint = a_hint();
 480  if (hint & A_HINT_DO) {
 481   a_map_store(o, o->op_ppaddr, hint);
 482   o->op_ppaddr = a_pp_deref;
 483  } else
 484   a_map_delete(o);
 485
 486  return o;
 487 }
 488
 489 /* ... ck_deref (aelem,helem,rv2sv) ........................................ */
 490
 491 STATIC OP *(*a_old_ck_aelem)(pTHX_ OP *) = 0;
 492 STATIC OP *(*a_old_ck_helem)(pTHX_ OP *) = 0;
 493 STATIC OP *(*a_old_ck_rv2sv)(pTHX_ OP *) = 0;
 494
 495 STATIC OP *a_ck_deref(pTHX_ OP *o) {
 496  OP * (*old_ck)(pTHX_ OP *o) = 0;
 497  UV hint;
 498
 499  switch (o->op_type) {
 500   case OP_AELEM: old_ck = a_old_ck_aelem; break;
 501   case OP_HELEM: old_ck = a_old_ck_helem; break;
 502   case OP_RV2SV: old_ck = a_old_ck_rv2sv; break;
 503  }
 504  o = CALL_FPTR(old_ck)(aTHX_ o);
 505
 506  hint = a_hint();
 507  if (hint & A_HINT_DO) {
 508   a_map_store(o, o->op_ppaddr, hint);
 509   o->op_ppaddr = a_pp_deref;
 510   a_map_set_root(o, hint);
 511  } else
 512   a_map_delete(o);
 513
 514  return o;
 515 }
 516
 517 /* ... ck_rv2xv (rv2av,rv2hv) .............................................. */
 518
 519 STATIC OP *(*a_old_ck_rv2av)(pTHX_ OP *) = 0;
 520 STATIC OP *(*a_old_ck_rv2hv)(pTHX_ OP *) = 0;
 521
 522 STATIC OP *a_ck_rv2xv(pTHX_ OP *o) {
 523  OP * (*old_ck)(pTHX_ OP *o) = 0;
 524  OP * (*new_pp)(pTHX)        = 0;
 525  UV hint;
 526
 527  switch (o->op_type) {
 528   case OP_RV2AV: old_ck = a_old_ck_rv2av; new_pp = a_pp_rv2av; break;
 529   case OP_RV2HV: old_ck = a_old_ck_rv2hv; new_pp = a_pp_rv2hv; break;
 530  }
 531  o = CALL_FPTR(old_ck)(aTHX_ o);
 532
 533  if (cUNOPo->op_first->op_type == OP_GV)
 534   return o;
 535
 536  hint = a_hint();
 537  if (hint & A_HINT_DO) {
 538   if (!(hint & A_HINT_STRICT)) {
 539    a_map_store(o, o->op_ppaddr, hint);
 540    o->op_ppaddr = new_pp;
 541   }
 542   a_map_set_root(o, hint);
 543  } else
 544   a_map_delete(o);
 545
 546  return o;
 547 }
 548
 549 /* ... ck_root (exists,delete,keys,values) ................................. */
 550
 551 STATIC OP *(*a_old_ck_exists)(pTHX_ OP *) = 0;
 552 STATIC OP *(*a_old_ck_delete)(pTHX_ OP *) = 0;
 553 STATIC OP *(*a_old_ck_keys)  (pTHX_ OP *) = 0;
 554 STATIC OP *(*a_old_ck_values)(pTHX_ OP *) = 0;
 555
 556 STATIC OP *a_ck_root(pTHX_ OP *o) {
 557  OP * (*old_ck)(pTHX_ OP *o) = 0;
 558  OP * (*new_pp)(pTHX)        = 0;
 559  bool enabled = FALSE;
 560  UV hint = a_hint();
 561
 562  switch (o->op_type) {
 563   case OP_EXISTS:
 564    old_ck  = a_old_ck_exists;
 565    new_pp  = a_pp_root_binop;
 566    enabled = hint & A_HINT_EXISTS;
 567    break;
 568   case OP_DELETE:
 569    old_ck  = a_old_ck_delete;
 570    new_pp  = a_pp_root_binop;
 571    enabled = hint & A_HINT_DELETE;
 572    break;
 573   case OP_KEYS:
 574    old_ck  = a_old_ck_keys;
 575    new_pp  = a_pp_root_unop;
 576    enabled = hint & A_HINT_FETCH;
 577    break;
 578   case OP_VALUES:
 579    old_ck  = a_old_ck_values;
 580    new_pp  = a_pp_root_unop;
 581    enabled = hint & A_HINT_FETCH;
 582    break;
 583  }
 584  o = CALL_FPTR(old_ck)(aTHX_ o);
 585
 586  if (hint & A_HINT_DO) {
 587   if (enabled) {
 588    a_map_set_root(o, hint | A_HINT_DEREF);
 589    a_map_store(o, o->op_ppaddr, hint);
 590    o->op_ppaddr = new_pp;
 591   } else {
 592    a_map_set_root(o, 0);
 593   }
 594  } else
 595   a_map_delete(o);
 596
 597  return o;
 598 }
 599
 600 STATIC U32 a_initialized = 0;
 601
 602 /* --- XS ------------------------------------------------------------------ */
 603
 604 MODULE = autovivification      PACKAGE = autovivification
 605
 606 PROTOTYPES: ENABLE
 607
 608 BOOT:
 609 {
 610  if (!a_initialized++) {
 611   HV *stash;
 612
 613   a_op_map = ptable_new();
 614 #ifdef USE_ITHREADS
 615   MUTEX_INIT(&a_op_map_mutex);
 616 #endif
 617
 618   PERL_HASH(a_hash, __PACKAGE__, __PACKAGE_LEN__);
 619
 620   a_old_ck_padany     = PL_check[OP_PADANY];
 621   PL_check[OP_PADANY] = MEMBER_TO_FPTR(a_ck_padany);
 622   a_old_ck_padsv      = PL_check[OP_PADSV];
 623   PL_check[OP_PADSV]  = MEMBER_TO_FPTR(a_ck_padsv);
 624
 625   a_old_ck_aelem      = PL_check[OP_AELEM];
 626   PL_check[OP_AELEM]  = MEMBER_TO_FPTR(a_ck_deref);
 627   a_old_ck_helem      = PL_check[OP_HELEM];
 628   PL_check[OP_HELEM]  = MEMBER_TO_FPTR(a_ck_deref);
 629   a_old_ck_rv2sv      = PL_check[OP_RV2SV];
 630   PL_check[OP_RV2SV]  = MEMBER_TO_FPTR(a_ck_deref);
 631
 632   a_old_ck_rv2av      = PL_check[OP_RV2AV];
 633   PL_check[OP_RV2AV]  = MEMBER_TO_FPTR(a_ck_rv2xv);
 634   a_old_ck_rv2hv      = PL_check[OP_RV2HV];
 635   PL_check[OP_RV2HV]  = MEMBER_TO_FPTR(a_ck_rv2xv);
 636
 637   a_old_ck_exists     = PL_check[OP_EXISTS];
 638   PL_check[OP_EXISTS] = MEMBER_TO_FPTR(a_ck_root);
 639   a_old_ck_delete     = PL_check[OP_DELETE];
 640   PL_check[OP_DELETE] = MEMBER_TO_FPTR(a_ck_root);
 641   a_old_ck_keys       = PL_check[OP_KEYS];
 642   PL_check[OP_KEYS]   = MEMBER_TO_FPTR(a_ck_root);
 643   a_old_ck_values     = PL_check[OP_VALUES];
 644   PL_check[OP_VALUES] = MEMBER_TO_FPTR(a_ck_root);
 645
 646   stash = gv_stashpvn(__PACKAGE__, __PACKAGE_LEN__, 1);
 647   newCONSTSUB(stash, "A_HINT_STRICT", newSVuv(A_HINT_STRICT));
 648   newCONSTSUB(stash, "A_HINT_WARN",   newSVuv(A_HINT_WARN));
 649   newCONSTSUB(stash, "A_HINT_FETCH",  newSVuv(A_HINT_FETCH));
 650   newCONSTSUB(stash, "A_HINT_STORE",  newSVuv(A_HINT_STORE));
 651   newCONSTSUB(stash, "A_HINT_EXISTS", newSVuv(A_HINT_EXISTS));
 652   newCONSTSUB(stash, "A_HINT_DELETE", newSVuv(A_HINT_DELETE));
 653   newCONSTSUB(stash, "A_HINT_MASK",   newSVuv(A_HINT_MASK));
 654  }
 655 }
 656
 657 SV *
 658 _tag(SV *hint)
 659 PROTOTYPE: $
 660 CODE:
 661  RETVAL = a_tag(SvOK(hint) ? SvUV(hint) : 0);
 662 OUTPUT:
 663  RETVAL
 664
 665 SV *
 666 _detag(SV *tag)
 667 PROTOTYPE: $
 668 CODE:
 669  if (!SvOK(tag))
 670   XSRETURN_UNDEF;
 671  RETVAL = newSVuv(a_detag(tag));
 672 OUTPUT:
 673  RETVAL