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