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