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