indirect.xs

   1 /* This file is part of the indirect Perl module.
   2  * See http://search.cpan.org/dist/indirect/ */
   3
   4 #define PERL_NO_GET_CONTEXT
   5 #include "EXTERN.h"
   6 #include "perl.h"
   7 #include "XSUB.h"
   8
   9 #define __PACKAGE__     "indirect"
  10 #define __PACKAGE_LEN__ (sizeof(__PACKAGE__)-1)
  11
  12 /* --- Compatibility wrappers ---------------------------------------------- */
  13
  14 #ifndef NOOP
  15 # define NOOP
  16 #endif
  17
  18 #ifndef dNOOP
  19 # define dNOOP
  20 #endif
  21
  22 #ifndef SvPV_const
  23 # define SvPV_const SvPV
  24 #endif
  25
  26 #ifndef SvPV_nolen_const
  27 # define SvPV_nolen_const SvPV_nolen
  28 #endif
  29
  30 #ifndef SvPVX_const
  31 # define SvPVX_const SvPVX
  32 #endif
  33
  34 #ifndef sv_catpvn_nomg
  35 # define sv_catpvn_nomg sv_catpvn
  36 #endif
  37
  38 #ifndef mPUSHu
  39 # define mPUSHu(U) PUSHs(sv_2mortal(newSVuv(U)))
  40 #endif
  41
  42 #ifndef HvNAME_get
  43 # define HvNAME_get(H) HvNAME(H)
  44 #endif
  45
  46 #ifndef HvNAMELEN_get
  47 # define HvNAMELEN_get(H) strlen(HvNAME_get(H))
  48 #endif
  49
  50 #define I_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
  51
  52 #if I_HAS_PERL(5, 10, 0) || defined(PL_parser)
  53 # ifndef PL_lex_inwhat
  54 #  define PL_lex_inwhat PL_parser->lex_inwhat
  55 # endif
  56 # ifndef PL_linestr
  57 #  define PL_linestr PL_parser->linestr
  58 # endif
  59 # ifndef PL_bufptr
  60 #  define PL_bufptr PL_parser->bufptr
  61 # endif
  62 # ifndef PL_oldbufptr
  63 #  define PL_oldbufptr PL_parser->oldbufptr
  64 # endif
  65 #else
  66 # ifndef PL_lex_inwhat
  67 #  define PL_lex_inwhat PL_Ilex_inwhat
  68 # endif
  69 # ifndef PL_linestr
  70 #  define PL_linestr PL_Ilinestr
  71 # endif
  72 # ifndef PL_bufptr
  73 #  define PL_bufptr PL_Ibufptr
  74 # endif
  75 # ifndef PL_oldbufptr
  76 #  define PL_oldbufptr PL_Ioldbufptr
  77 # endif
  78 #endif
  79
  80 #ifndef I_WORKAROUND_REQUIRE_PROPAGATION
  81 # define I_WORKAROUND_REQUIRE_PROPAGATION !I_HAS_PERL(5, 10, 1)
  82 #endif
  83
  84 /* ... Thread safety and multiplicity ...................................... */
  85
  86 #ifndef I_MULTIPLICITY
  87 # if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT)
  88 #  define I_MULTIPLICITY 1
  89 # else
  90 #  define I_MULTIPLICITY 0
  91 # endif
  92 #endif
  93 #if I_MULTIPLICITY && !defined(tTHX)
  94 # define tTHX PerlInterpreter*
  95 #endif
  96
  97 #if I_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))
  98 # define I_THREADSAFE 1
  99 # ifndef MY_CXT_CLONE
 100 #  define MY_CXT_CLONE \
 101     dMY_CXT_SV;                                                      \
 102     my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1)); \
 103     Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t); \
 104     sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
 105 # endif
 106 #else
 107 # define I_THREADSAFE 0
 108 # undef  dMY_CXT
 109 # define dMY_CXT      dNOOP
 110 # undef  MY_CXT
 111 # define MY_CXT       indirect_globaldata
 112 # undef  START_MY_CXT
 113 # define START_MY_CXT STATIC my_cxt_t MY_CXT;
 114 # undef  MY_CXT_INIT
 115 # define MY_CXT_INIT  NOOP
 116 # undef  MY_CXT_CLONE
 117 # define MY_CXT_CLONE NOOP
 118 #endif
 119
 120 /* --- Helpers ------------------------------------------------------------- */
 121
 122 /* ... Thread-safe hints ................................................... */
 123
 124 /* If any of those are true, we need to store the hint in a global table. */
 125
 126 #if I_THREADSAFE || I_WORKAROUND_REQUIRE_PROPAGATION
 127
 128 typedef struct {
 129  SV  *code;
 130 #if I_WORKAROUND_REQUIRE_PROPAGATION
 131  I32  requires;
 132 #endif
 133 } indirect_hint_t;
 134
 135 #define PTABLE_NAME ptable_hints
 136
 137 #if I_WORKAROUND_REQUIRE_PROPAGATION
 138 # define PTABLE_VAL_FREE(V) \
 139    { indirect_hint_t *h = (V); SvREFCNT_dec(h->code); PerlMemShared_free(h); }
 140 #else
 141 # define PTABLE_VAL_FREE(V) SvREFCNT_dec(V)
 142 #endif
 143
 144 #define pPTBL  pTHX
 145 #define pPTBL_ pTHX_
 146 #define aPTBL  aTHX
 147 #define aPTBL_ aTHX_
 148
 149 #include "ptable.h"
 150
 151 #define ptable_hints_store(T, K, V) ptable_hints_store(aTHX_ (T), (K), (V))
 152 #define ptable_hints_free(T)        ptable_hints_free(aTHX_ (T))
 153
 154 #endif /* I_THREADSAFE || I_WORKAROUND_REQUIRE_PROPAGATION */
 155
 156 /* Define the op->str ptable here because we need to be able to clean it during
 157  * thread cleanup. */
 158
 159 #define PTABLE_NAME        ptable
 160 #define PTABLE_VAL_FREE(V) SvREFCNT_dec(V)
 161
 162 #define pPTBL  pTHX
 163 #define pPTBL_ pTHX_
 164 #define aPTBL  aTHX
 165 #define aPTBL_ aTHX_
 166
 167 #include "ptable.h"
 168
 169 #define ptable_store(T, K, V) ptable_store(aTHX_ (T), (K), (V))
 170 #define ptable_clear(T)       ptable_clear(aTHX_ (T))
 171 #define ptable_free(T)        ptable_free(aTHX_ (T))
 172
 173 #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
 174
 175 typedef struct {
 176 #if I_THREADSAFE || I_WORKAROUND_REQUIRE_PROPAGATION
 177  ptable     *tbl; /* It really is a ptable_hints */
 178 #endif
 179  ptable     *map;
 180  const char *linestr;
 181 #if I_THREADSAFE
 182  tTHX        owner;
 183 #endif
 184 } my_cxt_t;
 185
 186 START_MY_CXT
 187
 188 #if I_THREADSAFE
 189
 190 STATIC void indirect_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) {
 191  my_cxt_t        *ud = ud_;
 192  indirect_hint_t *h1 = ent->val;
 193  indirect_hint_t *h2 = PerlMemShared_malloc(sizeof *h2);
 194
 195  *h2 = *h1;
 196
 197  if (ud->owner != aTHX) {
 198   SV *val = h1->code;
 199   CLONE_PARAMS param;
 200   AV *stashes = (SvTYPE(val) == SVt_PVHV && HvNAME_get(val)) ? newAV() : NULL;
 201   param.stashes    = stashes;
 202   param.flags      = 0;
 203   param.proto_perl = ud->owner;
 204   h2->code = sv_dup(val, &param);
 205   if (stashes) {
 206    av_undef(stashes);
 207    SvREFCNT_dec(stashes);
 208   }
 209  }
 210
 211  ptable_hints_store(ud->tbl, ent->key, h2);
 212  SvREFCNT_inc(h2->code);
 213 }
 214
 215 STATIC void indirect_thread_cleanup(pTHX_ void *);
 216
 217 STATIC void indirect_thread_cleanup(pTHX_ void *ud) {
 218  int *level = ud;
 219
 220  if (*level) {
 221   *level = 0;
 222   LEAVE;
 223   SAVEDESTRUCTOR_X(indirect_thread_cleanup, level);
 224   ENTER;
 225  } else {
 226   dMY_CXT;
 227   PerlMemShared_free(level);
 228   ptable_free(MY_CXT.map);
 229   ptable_hints_free(MY_CXT.tbl);
 230  }
 231 }
 232
 233 #endif /* I_THREADSAFE */
 234
 235 #if I_THREADSAFE || I_WORKAROUND_REQUIRE_PROPAGATION
 236
 237 STATIC SV *indirect_tag(pTHX_ SV *value) {
 238 #define indirect_tag(V) indirect_tag(aTHX_ (V))
 239  indirect_hint_t *h;
 240  dMY_CXT;
 241
 242  value = SvOK(value) && SvROK(value) ? SvRV(value) : NULL;
 243
 244  h = PerlMemShared_malloc(sizeof *h);
 245  h->code = SvREFCNT_inc(value);
 246
 247 #if I_WORKAROUND_REQUIRE_PROPAGATION
 248  {
 249   const PERL_SI *si;
 250   I32            requires = 0;
 251
 252   for (si = PL_curstackinfo; si; si = si->si_prev) {
 253    I32 cxix;
 254
 255    for (cxix = si->si_cxix; cxix >= 0; --cxix) {
 256     const PERL_CONTEXT *cx = si->si_cxstack + cxix;
 257
 258     if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_REQUIRE)
 259      ++requires;
 260    }
 261   }
 262
 263   h->requires = requires;
 264  }
 265 #endif
 266
 267  /* We only need for the key to be an unique tag for looking up the value later.
 268   * Allocated memory provides convenient unique identifiers, so that's why we
 269   * use the value pointer as the key itself. */
 270  ptable_hints_store(MY_CXT.tbl, value, h);
 271
 272  return newSVuv(PTR2UV(value));
 273 }
 274
 275 STATIC SV *indirect_detag(pTHX_ const SV *hint) {
 276 #define indirect_detag(H) indirect_detag(aTHX_ (H))
 277  indirect_hint_t *h;
 278  dMY_CXT;
 279
 280  if (!(hint && SvOK(hint) && SvIOK(hint)))
 281   return NULL;
 282
 283  h = ptable_fetch(MY_CXT.tbl, INT2PTR(void *, SvUVX(hint)));
 284
 285 #if I_WORKAROUND_REQUIRE_PROPAGATION
 286  {
 287   const PERL_SI *si;
 288   I32            requires = 0;
 289
 290   for (si = PL_curstackinfo; si; si = si->si_prev) {
 291    I32 cxix;
 292
 293    for (cxix = si->si_cxix; cxix >= 0; --cxix) {
 294     const PERL_CONTEXT *cx = si->si_cxstack + cxix;
 295
 296     if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_REQUIRE
 297                                && ++requires > h->requires)
 298      return NULL;
 299    }
 300   }
 301  }
 302 #endif
 303
 304  return h->code;
 305 }
 306
 307 #else
 308
 309 STATIC SV *indirect_tag(pTHX_ SV *value) {
 310 #define indirect_tag(V) indirect_tag(aTHX_ (V))
 311  UV tag = 0;
 312
 313  if (SvOK(value) && SvROK(value)) {
 314   value = SvRV(value);
 315   SvREFCNT_inc(value);
 316   tag = PTR2UV(value);
 317  }
 318
 319  return newSVuv(tag);
 320 }
 321
 322 #define indirect_detag(H) (((H) && SvOK(H)) ? INT2PTR(SV *, SvUVX(H)) : NULL)
 323
 324 #endif /* I_THREADSAFE || I_WORKAROUND_REQUIRE_PROPAGATION */
 325
 326 STATIC U32 indirect_hash = 0;
 327
 328 STATIC SV *indirect_hint(pTHX) {
 329 #define indirect_hint() indirect_hint(aTHX)
 330  SV *hint, *code;
 331 #if I_HAS_PERL(5, 9, 5)
 332  hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
 333                                        NULL,
 334                                        __PACKAGE__, __PACKAGE_LEN__,
 335                                        0,
 336                                        indirect_hash);
 337 #else
 338  SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__,
 339                                                                  indirect_hash);
 340  if (!val)
 341   return 0;
 342  hint = *val;
 343 #endif
 344  return indirect_detag(hint);
 345 }
 346
 347 /* ... op -> source position ............................................... */
 348
 349 STATIC void indirect_map_store(pTHX_ const OP *o, const char *src, SV *sv) {
 350 #define indirect_map_store(O, S, N) indirect_map_store(aTHX_ (O), (S), (N))
 351  dMY_CXT;
 352  SV *val;
 353
 354  /* When lex_inwhat is set, we're in a quotelike environment (qq, qr, but not q)
 355   * In this case the linestr has temporarly changed, but the old buffer should
 356   * still be alive somewhere. */
 357
 358  if (!PL_lex_inwhat) {
 359   const char *pl_linestr = SvPVX_const(PL_linestr);
 360   if (MY_CXT.linestr != pl_linestr) {
 361    ptable_clear(MY_CXT.map);
 362    MY_CXT.linestr = pl_linestr;
 363   }
 364  }
 365
 366  val = newSVsv(sv);
 367  SvUPGRADE(val, SVt_PVIV);
 368  SvUVX(val) = PTR2UV(src);
 369  SvIOK_on(val);
 370  SvIsUV_on(val);
 371  SvREADONLY_on(val);
 372
 373  ptable_store(MY_CXT.map, o, val);
 374 }
 375
 376 STATIC const char *indirect_map_fetch(pTHX_ const OP *o, SV ** const name) {
 377 #define indirect_map_fetch(O, S) indirect_map_fetch(aTHX_ (O), (S))
 378  dMY_CXT;
 379  SV *val;
 380
 381  if (MY_CXT.linestr != SvPVX_const(PL_linestr))
 382   return NULL;
 383
 384  val = ptable_fetch(MY_CXT.map, o);
 385  if (!val) {
 386   *name = NULL;
 387   return NULL;
 388  }
 389
 390  *name = val;
 391  return INT2PTR(const char *, SvUVX(val));
 392 }
 393
 394 /* --- Check functions ----------------------------------------------------- */
 395
 396 STATIC const char *indirect_find(pTHX_ SV *sv, const char *s) {
 397 #define indirect_find(N, S) indirect_find(aTHX_ (N), (S))
 398  STRLEN len;
 399  const char *p = NULL, *r = SvPV_const(sv, len);
 400
 401  if (len >= 1 && *r == '$') {
 402   ++r;
 403   --len;
 404   s = strchr(s, '$');
 405   if (!s)
 406    return NULL;
 407  }
 408
 409  p = strstr(s, r);
 410  while (p) {
 411   p += len;
 412   if (!isALNUM(*p))
 413    break;
 414   p = strstr(p + 1, r);
 415  }
 416
 417  return p;
 418 }
 419
 420 /* ... ck_const ............................................................ */
 421
 422 STATIC OP *(*indirect_old_ck_const)(pTHX_ OP *) = 0;
 423
 424 STATIC OP *indirect_ck_const(pTHX_ OP *o) {
 425  o = CALL_FPTR(indirect_old_ck_const)(aTHX_ o);
 426
 427  if (indirect_hint()) {
 428   SV *sv = cSVOPo_sv;
 429   if (SvPOK(sv) && (SvTYPE(sv) >= SVt_PV))
 430    indirect_map_store(o, indirect_find(sv, PL_oldbufptr), sv);
 431  }
 432
 433  return o;
 434 }
 435
 436 /* ... ck_rv2sv ............................................................ */
 437
 438 STATIC OP *(*indirect_old_ck_rv2sv)(pTHX_ OP *) = 0;
 439
 440 STATIC OP *indirect_ck_rv2sv(pTHX_ OP *o) {
 441  if (indirect_hint()) {
 442   OP *op = cUNOPo->op_first;
 443   SV *sv;
 444   const char *name = NULL, *s;
 445   STRLEN len;
 446   OPCODE type = (OPCODE) op->op_type;
 447
 448   switch (type) {
 449    case OP_GV:
 450    case OP_GVSV: {
 451     GV *gv = cGVOPx_gv(op);
 452     name = GvNAME(gv);
 453     len  = GvNAMELEN(gv);
 454     break;
 455    }
 456    default:
 457     if ((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP) {
 458      SV *nsv = cSVOPx_sv(op);
 459      if (SvPOK(nsv) && (SvTYPE(nsv) >= SVt_PV))
 460       name = SvPV_const(nsv, len);
 461     }
 462   }
 463   if (!name)
 464    goto done;
 465
 466   sv = sv_2mortal(newSVpvn("$", 1));
 467   sv_catpvn_nomg(sv, name, len);
 468   s = indirect_find(sv, PL_oldbufptr);
 469   if (!s) { /* If it failed, retry without the current stash */
 470    const char *stash = HvNAME_get(PL_curstash);
 471    STRLEN stashlen = HvNAMELEN_get(PL_curstash);
 472
 473    if ((len < stashlen + 2) || strnNE(name, stash, stashlen)
 474        || name[stashlen] != ':' || name[stashlen+1] != ':') {
 475     /* Failed again ? Try to remove main */
 476     stash = "main";
 477     stashlen = 4;
 478     if ((len < stashlen + 2) || strnNE(name, stash, stashlen)
 479         || name[stashlen] != ':' || name[stashlen+1] != ':')
 480      goto done;
 481    }
 482
 483    sv_setpvn(sv, "$", 1);
 484    stashlen += 2;
 485    sv_catpvn_nomg(sv, name + stashlen, len - stashlen);
 486    s = indirect_find(sv, PL_oldbufptr);
 487    if (!s)
 488     goto done;
 489   }
 490
 491   o = CALL_FPTR(indirect_old_ck_rv2sv)(aTHX_ o);
 492   indirect_map_store(o, s, sv);
 493   return o;
 494  }
 495
 496 done:
 497  return CALL_FPTR(indirect_old_ck_rv2sv)(aTHX_ o);
 498 }
 499
 500 /* ... ck_padany ........................................................... */
 501
 502 STATIC OP *(*indirect_old_ck_padany)(pTHX_ OP *) = 0;
 503
 504 STATIC OP *indirect_ck_padany(pTHX_ OP *o) {
 505  o = CALL_FPTR(indirect_old_ck_padany)(aTHX_ o);
 506
 507  if (indirect_hint()) {
 508   SV *sv;
 509   const char *s = PL_oldbufptr, *t = PL_bufptr - 1;
 510
 511   while (s < t && isSPACE(*s)) ++s;
 512   if (*s == '$' && ++s <= t) {
 513    while (s < t && isSPACE(*s)) ++s;
 514    while (s < t && isSPACE(*t)) --t;
 515    sv = sv_2mortal(newSVpvn("$", 1));
 516    sv_catpvn_nomg(sv, s, t - s + 1);
 517    indirect_map_store(o, s, sv);
 518   }
 519  }
 520
 521  return o;
 522 }
 523
 524 /* ... ck_method ........................................................... */
 525
 526 STATIC OP *(*indirect_old_ck_method)(pTHX_ OP *) = 0;
 527
 528 STATIC OP *indirect_ck_method(pTHX_ OP *o) {
 529  if (indirect_hint()) {
 530   OP *op = cUNOPo->op_first;
 531   SV *sv;
 532   const char *s = indirect_map_fetch(op, &sv);
 533   if (!s) {
 534    sv = cSVOPx_sv(op);
 535    if (!SvPOK(sv) || (SvTYPE(sv) < SVt_PV))
 536     goto done;
 537    sv = sv_mortalcopy(sv);
 538    s  = indirect_find(sv, PL_oldbufptr);
 539   }
 540   o = CALL_FPTR(indirect_old_ck_method)(aTHX_ o);
 541   /* o may now be a method_named */
 542   indirect_map_store(o, s, sv);
 543   return o;
 544  }
 545
 546 done:
 547  return CALL_FPTR(indirect_old_ck_method)(aTHX_ o);
 548 }
 549
 550 /* ... ck_entersub ......................................................... */
 551
 552 STATIC OP *(*indirect_old_ck_entersub)(pTHX_ OP *) = 0;
 553
 554 STATIC OP *indirect_ck_entersub(pTHX_ OP *o) {
 555  SV *code = indirect_hint();
 556
 557  o = CALL_FPTR(indirect_old_ck_entersub)(aTHX_ o);
 558
 559  if (code) {
 560   const char *mpos, *opos;
 561   SV *mnamesv, *onamesv;
 562   OP *mop, *oop;
 563   LISTOP *lop;
 564
 565   oop = o;
 566   do {
 567    lop = (LISTOP *) oop;
 568    if (!(lop->op_flags & OPf_KIDS))
 569     goto done;
 570    oop = lop->op_first;
 571   } while (oop->op_type != OP_PUSHMARK);
 572   oop = oop->op_sibling;
 573   mop = lop->op_last;
 574
 575   if (mop->op_type == OP_METHOD)
 576    mop = cUNOPx(mop)->op_first;
 577   else if (mop->op_type != OP_METHOD_NAMED)
 578    goto done;
 579
 580   mpos = indirect_map_fetch(mop, &mnamesv);
 581   if (!mpos)
 582    goto done;
 583
 584   opos = indirect_map_fetch(oop, &onamesv);
 585   if (!opos)
 586    goto done;
 587
 588   if (mpos < opos) {
 589    SV     *file;
 590    line_t  line;
 591    dSP;
 592
 593    ENTER;
 594    SAVETMPS;
 595
 596    onamesv = sv_mortalcopy(onamesv);
 597    mnamesv = sv_mortalcopy(mnamesv);
 598
 599 #ifdef USE_ITHREADS
 600    file = sv_2mortal(newSVpv(CopFILE(&PL_compiling), 0));
 601 #else
 602    file = sv_mortalcopy(CopFILESV(&PL_compiling));
 603 #endif
 604    line = CopLINE(&PL_compiling);
 605
 606    PUSHMARK(SP);
 607    EXTEND(SP, 4);
 608    PUSHs(onamesv);
 609    PUSHs(mnamesv);
 610    PUSHs(file);
 611    mPUSHu(line);
 612    PUTBACK;
 613
 614    call_sv(code, G_VOID);
 615
 616    PUTBACK;
 617
 618    FREETMPS;
 619    LEAVE;
 620   }
 621  }
 622
 623 done:
 624  return o;
 625 }
 626
 627 STATIC U32 indirect_initialized = 0;
 628
 629 /* --- XS ------------------------------------------------------------------ */
 630
 631 MODULE = indirect      PACKAGE = indirect
 632
 633 PROTOTYPES: ENABLE
 634
 635 BOOT:
 636 {
 637  if (!indirect_initialized++) {
 638   HV *stash;
 639
 640   MY_CXT_INIT;
 641   MY_CXT.map     = ptable_new();
 642   MY_CXT.linestr = NULL;
 643 #if I_THREADSAFE || I_WORKAROUND_REQUIRE_PROPAGATION
 644   MY_CXT.tbl     = ptable_new();
 645 #endif
 646 #if I_THREADSAFE
 647   MY_CXT.owner   = aTHX;
 648 #endif
 649
 650   PERL_HASH(indirect_hash, __PACKAGE__, __PACKAGE_LEN__);
 651
 652   indirect_old_ck_const    = PL_check[OP_CONST];
 653   PL_check[OP_CONST]       = MEMBER_TO_FPTR(indirect_ck_const);
 654   indirect_old_ck_rv2sv    = PL_check[OP_RV2SV];
 655   PL_check[OP_RV2SV]       = MEMBER_TO_FPTR(indirect_ck_rv2sv);
 656   indirect_old_ck_padany   = PL_check[OP_PADANY];
 657   PL_check[OP_PADANY]      = MEMBER_TO_FPTR(indirect_ck_padany);
 658   indirect_old_ck_method   = PL_check[OP_METHOD];
 659   PL_check[OP_METHOD]      = MEMBER_TO_FPTR(indirect_ck_method);
 660   indirect_old_ck_entersub = PL_check[OP_ENTERSUB];
 661   PL_check[OP_ENTERSUB]    = MEMBER_TO_FPTR(indirect_ck_entersub);
 662
 663   stash = gv_stashpvn(__PACKAGE__, __PACKAGE_LEN__, 1);
 664   newCONSTSUB(stash, "I_THREADSAFE", newSVuv(I_THREADSAFE));
 665  }
 666 }
 667
 668 #if I_THREADSAFE
 669
 670 void
 671 CLONE(...)
 672 PROTOTYPE: DISABLE
 673 PREINIT:
 674  ptable *t;
 675  int    *level;
 676 CODE:
 677  {
 678   my_cxt_t ud;
 679   dMY_CXT;
 680   ud.tbl   = t = ptable_new();
 681   ud.owner = MY_CXT.owner;
 682   ptable_walk(MY_CXT.tbl, indirect_ptable_clone, &ud);
 683  }
 684  {
 685   MY_CXT_CLONE;
 686   MY_CXT.map     = ptable_new();
 687   MY_CXT.linestr = NULL;
 688   MY_CXT.tbl     = t;
 689   MY_CXT.owner   = aTHX;
 690  }
 691  {
 692   level = PerlMemShared_malloc(sizeof *level);
 693   *level = 1;
 694   LEAVE;
 695   SAVEDESTRUCTOR_X(indirect_thread_cleanup, level);
 696   ENTER;
 697  }
 698
 699 #endif
 700
 701 SV *
 702 _tag(SV *value)
 703 PROTOTYPE: $
 704 CODE:
 705  RETVAL = indirect_tag(value);
 706 OUTPUT:
 707  RETVAL