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