57e78e1c315cce3273b2089a0909b28e401297a6
[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
355  if (IN_PERL_RUNTIME)
356   return NULL;
357
358 #if I_HAS_PERL(5, 9, 5)
359  hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
360                                        NULL,
361                                        __PACKAGE__, __PACKAGE_LEN__,
362                                        0,
363                                        indirect_hash);
364 #else
365  {
366   SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__,
367                                                                  indirect_hash);
368   if (!val)
369    return 0;
370   hint = *val;
371  }
372 #endif
373  return indirect_detag(hint);
374 }
375
376 /* ... op -> source position ............................................... */
377
378 STATIC void indirect_map_store(pTHX_ const OP *o, const char *src, SV *sv, line_t line) {
379 #define indirect_map_store(O, S, N, L) indirect_map_store(aTHX_ (O), (S), (N), (L))
380  indirect_op_info_t *oi;
381  const char *s;
382  STRLEN len;
383  dMY_CXT;
384
385  /* When lex_inwhat is set, we're in a quotelike environment (qq, qr, but not q)
386   * In this case the linestr has temporarly changed, but the old buffer should
387   * still be alive somewhere. */
388
389  if (!PL_lex_inwhat) {
390   const char *pl_linestr = SvPVX_const(PL_linestr);
391   if (MY_CXT.linestr != pl_linestr) {
392    ptable_clear(MY_CXT.map);
393    MY_CXT.linestr = pl_linestr;
394   }
395  }
396
397  if (!(oi = ptable_fetch(MY_CXT.map, o))) {
398   Newx(oi, 1, indirect_op_info_t);
399   ptable_store(MY_CXT.map, o, oi);
400   oi->buf  = NULL;
401   oi->size = 0;
402  }
403
404  if (sv) {
405   s = SvPV_const(sv, len);
406  } else {
407   s   = "{";
408   len = 1;
409  }
410
411  if (len > oi->size) {
412   Safefree(oi->buf);
413   Newx(oi->buf, len, char);
414   oi->size = len;
415  }
416  Copy(s, oi->buf, len, char);
417
418  oi->len  = len;
419  oi->pos  = src;
420  oi->line = line;
421 }
422
423 STATIC const indirect_op_info_t *indirect_map_fetch(pTHX_ const OP *o) {
424 #define indirect_map_fetch(O) indirect_map_fetch(aTHX_ (O))
425  const indirect_op_info_t *val;
426  dMY_CXT;
427
428  if (MY_CXT.linestr != SvPVX_const(PL_linestr))
429   return NULL;
430
431  return ptable_fetch(MY_CXT.map, o);
432 }
433
434 STATIC void indirect_map_delete(pTHX_ const OP *o) {
435 #define indirect_map_delete(O) indirect_map_delete(aTHX_ (O))
436  dMY_CXT;
437
438  ptable_store(MY_CXT.map, o, NULL);
439 }
440
441 /* --- Check functions ----------------------------------------------------- */
442
443 STATIC const char *indirect_find(pTHX_ SV *sv, const char *s) {
444 #define indirect_find(N, S) indirect_find(aTHX_ (N), (S))
445  STRLEN len;
446  const char *p = NULL, *r = SvPV_const(sv, len);
447
448  if (len >= 1 && *r == '$') {
449   ++r;
450   --len;
451   s = strchr(s, '$');
452   if (!s)
453    return NULL;
454  }
455
456  p = strstr(s, r);
457  while (p) {
458   p += len;
459   if (!isALNUM(*p))
460    break;
461   p = strstr(p + 1, r);
462  }
463
464  return p;
465 }
466
467 /* ... ck_const ............................................................ */
468
469 STATIC OP *(*indirect_old_ck_const)(pTHX_ OP *) = 0;
470
471 STATIC OP *indirect_ck_const(pTHX_ OP *o) {
472  o = CALL_FPTR(indirect_old_ck_const)(aTHX_ o);
473
474  if (indirect_hint()) {
475   SV *sv = cSVOPo_sv;
476   if (SvPOK(sv) && (SvTYPE(sv) >= SVt_PV)) {
477    const char *s = indirect_find(sv, PL_oldbufptr);
478    indirect_map_store(o, s, sv, CopLINE(&PL_compiling));
479    return o;
480   }
481  }
482
483  indirect_map_delete(o);
484  return o;
485 }
486
487 /* ... ck_rv2sv ............................................................ */
488
489 STATIC OP *(*indirect_old_ck_rv2sv)(pTHX_ OP *) = 0;
490
491 STATIC OP *indirect_ck_rv2sv(pTHX_ OP *o) {
492  if (indirect_hint()) {
493   OP *op = cUNOPo->op_first;
494   SV *sv;
495   const char *name = NULL, *s;
496   STRLEN len;
497   OPCODE type = (OPCODE) op->op_type;
498
499   switch (type) {
500    case OP_GV:
501    case OP_GVSV: {
502     GV *gv = cGVOPx_gv(op);
503     name = GvNAME(gv);
504     len  = GvNAMELEN(gv);
505     break;
506    }
507    default:
508     if ((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP) {
509      SV *nsv = cSVOPx_sv(op);
510      if (SvPOK(nsv) && (SvTYPE(nsv) >= SVt_PV))
511       name = SvPV_const(nsv, len);
512     }
513   }
514   if (!name)
515    goto done;
516
517   sv = sv_2mortal(newSVpvn("$", 1));
518   sv_catpvn_nomg(sv, name, len);
519   s = indirect_find(sv, PL_oldbufptr);
520   if (!s) { /* If it failed, retry without the current stash */
521    const char *stash = HvNAME_get(PL_curstash);
522    STRLEN stashlen = HvNAMELEN_get(PL_curstash);
523
524    if ((len < stashlen + 2) || strnNE(name, stash, stashlen)
525        || name[stashlen] != ':' || name[stashlen+1] != ':') {
526     /* Failed again ? Try to remove main */
527     stash = "main";
528     stashlen = 4;
529     if ((len < stashlen + 2) || strnNE(name, stash, stashlen)
530         || name[stashlen] != ':' || name[stashlen+1] != ':')
531      goto done;
532    }
533
534    sv_setpvn(sv, "$", 1);
535    stashlen += 2;
536    sv_catpvn_nomg(sv, name + stashlen, len - stashlen);
537    s = indirect_find(sv, PL_oldbufptr);
538    if (!s)
539     goto done;
540   }
541
542   o = CALL_FPTR(indirect_old_ck_rv2sv)(aTHX_ o);
543   indirect_map_store(o, s, sv, CopLINE(&PL_compiling));
544   return o;
545  }
546
547 done:
548  o = CALL_FPTR(indirect_old_ck_rv2sv)(aTHX_ o);
549
550  indirect_map_delete(o);
551  return o;
552 }
553
554 /* ... ck_padany ........................................................... */
555
556 STATIC OP *(*indirect_old_ck_padany)(pTHX_ OP *) = 0;
557
558 STATIC OP *indirect_ck_padany(pTHX_ OP *o) {
559  o = CALL_FPTR(indirect_old_ck_padany)(aTHX_ o);
560
561  if (indirect_hint()) {
562   SV *sv;
563   const char *s = PL_oldbufptr, *t = PL_bufptr - 1;
564
565   while (s < t && isSPACE(*s)) ++s;
566   if (*s == '$' && ++s <= t) {
567    while (s < t && isSPACE(*s)) ++s;
568    while (s < t && isSPACE(*t)) --t;
569    sv = sv_2mortal(newSVpvn("$", 1));
570    sv_catpvn_nomg(sv, s, t - s + 1);
571    indirect_map_store(o, s, sv, CopLINE(&PL_compiling));
572    return o;
573   }
574  }
575
576  indirect_map_delete(o);
577  return o;
578 }
579
580 /* ... ck_scope ............................................................ */
581
582 STATIC OP *(*indirect_old_ck_scope)  (pTHX_ OP *) = 0;
583 STATIC OP *(*indirect_old_ck_lineseq)(pTHX_ OP *) = 0;
584
585 STATIC OP *indirect_ck_scope(pTHX_ OP *o) {
586  OP *(*old_ck)(pTHX_ OP *) = 0;
587
588  switch (o->op_type) {
589   case OP_SCOPE:   old_ck = indirect_old_ck_scope;   break;
590   case OP_LINESEQ: old_ck = indirect_old_ck_lineseq; break;
591  }
592  o = CALL_FPTR(old_ck)(aTHX_ o);
593
594  if (indirect_hint()) {
595   indirect_map_store(o, PL_oldbufptr, NULL, CopLINE(&PL_compiling));
596   return o;
597  }
598
599  indirect_map_delete(o);
600  return o;
601 }
602
603 /* We don't need to clean the map entries for leave ops because they can only
604  * be created by mutating from a lineseq. */
605
606 /* ... ck_method ........................................................... */
607
608 STATIC OP *(*indirect_old_ck_method)(pTHX_ OP *) = 0;
609
610 STATIC OP *indirect_ck_method(pTHX_ OP *o) {
611  if (indirect_hint()) {
612   OP *op = cUNOPo->op_first;
613   const indirect_op_info_t *oi = indirect_map_fetch(op);
614   const char *s = NULL;
615   line_t line;
616   SV *sv;
617
618   if (oi && (s = oi->pos)) {
619    sv   = sv_2mortal(newSVpvn(oi->buf, oi->len));
620    line = oi->line; /* Keep the old line so that we really point to the first */
621   } else {
622    sv = cSVOPx_sv(op);
623    if (!SvPOK(sv) || (SvTYPE(sv) < SVt_PV))
624     goto done;
625    sv   = sv_mortalcopy(sv);
626    s    = indirect_find(sv, PL_oldbufptr);
627    line = CopLINE(&PL_compiling);
628   }
629
630   o = CALL_FPTR(indirect_old_ck_method)(aTHX_ o);
631   /* o may now be a method_named */
632
633   indirect_map_store(o, s, sv, line);
634   return o;
635  }
636
637 done:
638  o = CALL_FPTR(indirect_old_ck_method)(aTHX_ o);
639
640  indirect_map_delete(o);
641  return o;
642 }
643
644 /* ... ck_entersub ......................................................... */
645
646 STATIC int indirect_is_indirect(const indirect_op_info_t *moi, const indirect_op_info_t *ooi) {
647  if (moi->pos > ooi->pos)
648   return 0;
649
650  if (moi->pos == ooi->pos)
651   return moi->len == ooi->len && !memcmp(moi->buf, ooi->buf, moi->len);
652
653  return 1;
654 }
655
656 STATIC OP *(*indirect_old_ck_entersub)(pTHX_ OP *) = 0;
657
658 STATIC OP *indirect_ck_entersub(pTHX_ OP *o) {
659  SV *code = indirect_hint();
660
661  o = CALL_FPTR(indirect_old_ck_entersub)(aTHX_ o);
662
663  if (code) {
664   const indirect_op_info_t *moi, *ooi;
665   OP     *mop, *oop;
666   LISTOP *lop;
667
668   oop = o;
669   do {
670    lop = (LISTOP *) oop;
671    if (!(lop->op_flags & OPf_KIDS))
672     goto done;
673    oop = lop->op_first;
674   } while (oop->op_type != OP_PUSHMARK);
675   oop = oop->op_sibling;
676   mop = lop->op_last;
677
678   if (!oop)
679    goto done;
680
681   switch (oop->op_type) {
682    case OP_CONST:
683    case OP_RV2SV:
684    case OP_PADSV:
685    case OP_SCOPE:
686    case OP_LEAVE:
687     break;
688    default:
689     goto done;
690   }
691
692   if (mop->op_type == OP_METHOD)
693    mop = cUNOPx(mop)->op_first;
694   else if (mop->op_type != OP_METHOD_NAMED)
695    goto done;
696
697   moi = indirect_map_fetch(mop);
698   if (!(moi && moi->pos))
699    goto done;
700
701   ooi = indirect_map_fetch(oop);
702   if (!(ooi && ooi->pos))
703    goto done;
704
705   if (indirect_is_indirect(moi, ooi)) {
706    SV *file;
707    dSP;
708
709    ENTER;
710    SAVETMPS;
711
712 #ifdef USE_ITHREADS
713    file = sv_2mortal(newSVpv(CopFILE(&PL_compiling), 0));
714 #else
715    file = sv_mortalcopy(CopFILESV(&PL_compiling));
716 #endif
717
718    PUSHMARK(SP);
719    EXTEND(SP, 4);
720    mPUSHp(ooi->buf, ooi->len);
721    mPUSHp(moi->buf, moi->len);
722    PUSHs(file);
723    mPUSHu(moi->line);
724    PUTBACK;
725
726    call_sv(code, G_VOID);
727
728    PUTBACK;
729
730    FREETMPS;
731    LEAVE;
732   }
733  }
734
735 done:
736  return o;
737 }
738
739 STATIC U32 indirect_initialized = 0;
740
741 /* --- XS ------------------------------------------------------------------ */
742
743 MODULE = indirect      PACKAGE = indirect
744
745 PROTOTYPES: ENABLE
746
747 BOOT:
748 {
749  if (!indirect_initialized++) {
750   HV *stash;
751
752   MY_CXT_INIT;
753   MY_CXT.map     = ptable_new();
754   MY_CXT.linestr = NULL;
755 #if I_THREADSAFE || I_WORKAROUND_REQUIRE_PROPAGATION
756   MY_CXT.tbl     = ptable_new();
757 #endif
758 #if I_THREADSAFE
759   MY_CXT.owner   = aTHX;
760 #endif
761
762   PERL_HASH(indirect_hash, __PACKAGE__, __PACKAGE_LEN__);
763
764   indirect_old_ck_const    = PL_check[OP_CONST];
765   PL_check[OP_CONST]       = MEMBER_TO_FPTR(indirect_ck_const);
766   indirect_old_ck_rv2sv    = PL_check[OP_RV2SV];
767   PL_check[OP_RV2SV]       = MEMBER_TO_FPTR(indirect_ck_rv2sv);
768   indirect_old_ck_padany   = PL_check[OP_PADANY];
769   PL_check[OP_PADANY]      = MEMBER_TO_FPTR(indirect_ck_padany);
770   indirect_old_ck_scope    = PL_check[OP_SCOPE];
771   PL_check[OP_SCOPE]       = MEMBER_TO_FPTR(indirect_ck_scope);
772   indirect_old_ck_lineseq  = PL_check[OP_LINESEQ];
773   PL_check[OP_LINESEQ]     = MEMBER_TO_FPTR(indirect_ck_scope);
774
775   indirect_old_ck_method   = PL_check[OP_METHOD];
776   PL_check[OP_METHOD]      = MEMBER_TO_FPTR(indirect_ck_method);
777   indirect_old_ck_entersub = PL_check[OP_ENTERSUB];
778   PL_check[OP_ENTERSUB]    = MEMBER_TO_FPTR(indirect_ck_entersub);
779
780   stash = gv_stashpvn(__PACKAGE__, __PACKAGE_LEN__, 1);
781   newCONSTSUB(stash, "I_THREADSAFE", newSVuv(I_THREADSAFE));
782  }
783 }
784
785 #if I_THREADSAFE
786
787 void
788 CLONE(...)
789 PROTOTYPE: DISABLE
790 PREINIT:
791  ptable *t;
792  int    *level;
793 CODE:
794  {
795   my_cxt_t ud;
796   dMY_CXT;
797   ud.tbl   = t = ptable_new();
798   ud.owner = MY_CXT.owner;
799   ptable_walk(MY_CXT.tbl, indirect_ptable_clone, &ud);
800  }
801  {
802   MY_CXT_CLONE;
803   MY_CXT.map     = ptable_new();
804   MY_CXT.linestr = NULL;
805   MY_CXT.tbl     = t;
806   MY_CXT.owner   = aTHX;
807  }
808  {
809   level = PerlMemShared_malloc(sizeof *level);
810   *level = 1;
811   LEAVE;
812   SAVEDESTRUCTOR_X(indirect_thread_cleanup, level);
813   ENTER;
814  }
815
816 #endif
817
818 SV *
819 _tag(SV *value)
820 PROTOTYPE: $
821 CODE:
822  RETVAL = indirect_tag(value);
823 OUTPUT:
824  RETVAL