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