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