e1961194bf1585b083f947d0201ceaca4bfed003
[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, *name_end;
501  const char *line, *line_end;
502  const char *p, *t, *u;
503
504  line     = SvPV_const(PL_linestr, line_len);
505  line_end = line + line_len;
506
507  name = SvPV_const(name_sv, name_len);
508  if (name_len >= 1 && *name == '$') {
509   ++name;
510   --name_len;
511   while (line_bufptr < line_end && *line_bufptr != '$')
512    ++line_bufptr;
513   if (line_bufptr >= line_end)
514    return 0;
515  }
516  name_end = name + name_len;
517
518  p = line_bufptr;
519  while (1) {
520   p = ninstr(p, line_end, name, name_end);
521   if (!p)
522    return 0;
523   if (!isALNUM(p[name_len]))
524    break;
525   /* p points to a word that has name as prefix, skip the rest of the word */
526   p += name_len + 1;
527   while (isALNUM(*p))
528    ++p;
529  }
530
531  t = line;
532  u = t;
533  while (t <= p) {
534   STRLEN i = indirect_nextline(t, line_len);
535   if (i >= line_len)
536    break;
537   u         = t;
538   t        += i;
539   line_len -= i;
540  }
541  *name_pos = p - u;
542
543  return 1;
544 }
545
546 /* ... ck_const ............................................................ */
547
548 STATIC OP *(*indirect_old_ck_const)(pTHX_ OP *) = 0;
549
550 STATIC OP *indirect_ck_const(pTHX_ OP *o) {
551  o = indirect_old_ck_const(aTHX_ o);
552
553  if (indirect_hint()) {
554   SV *sv = cSVOPo_sv;
555
556   if (SvPOK(sv) && (SvTYPE(sv) >= SVt_PV)) {
557    STRLEN pos;
558
559    if (indirect_find(sv, PL_oldbufptr, &pos)) {
560     indirect_map_store(o, pos, sv, CopLINE(&PL_compiling));
561     return o;
562    }
563   }
564  }
565
566  indirect_map_delete(o);
567  return o;
568 }
569
570 /* ... ck_rv2sv ............................................................ */
571
572 STATIC OP *(*indirect_old_ck_rv2sv)(pTHX_ OP *) = 0;
573
574 STATIC OP *indirect_ck_rv2sv(pTHX_ OP *o) {
575  if (indirect_hint()) {
576   OP *op = cUNOPo->op_first;
577   SV *sv;
578   const char *name = NULL;
579   STRLEN pos, len;
580   OPCODE type = (OPCODE) op->op_type;
581
582   switch (type) {
583    case OP_GV:
584    case OP_GVSV: {
585     GV *gv = cGVOPx_gv(op);
586     name = GvNAME(gv);
587     len  = GvNAMELEN(gv);
588     break;
589    }
590    default:
591     if ((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP) {
592      SV *nsv = cSVOPx_sv(op);
593      if (SvPOK(nsv) && (SvTYPE(nsv) >= SVt_PV))
594       name = SvPV_const(nsv, len);
595     }
596   }
597   if (!name)
598    goto done;
599
600   sv = sv_2mortal(newSVpvn("$", 1));
601   sv_catpvn_nomg(sv, name, len);
602   if (!indirect_find(sv, PL_oldbufptr, &pos)) {
603    /* If it failed, retry without the current stash */
604    const char *stash = HvNAME_get(PL_curstash);
605    STRLEN stashlen = HvNAMELEN_get(PL_curstash);
606
607    if ((len < stashlen + 2) || strnNE(name, stash, stashlen)
608        || name[stashlen] != ':' || name[stashlen+1] != ':') {
609     /* Failed again ? Try to remove main */
610     stash = "main";
611     stashlen = 4;
612     if ((len < stashlen + 2) || strnNE(name, stash, stashlen)
613         || name[stashlen] != ':' || name[stashlen+1] != ':')
614      goto done;
615    }
616
617    sv_setpvn(sv, "$", 1);
618    stashlen += 2;
619    sv_catpvn_nomg(sv, name + stashlen, len - stashlen);
620    if (!indirect_find(sv, PL_oldbufptr, &pos))
621     goto done;
622   }
623
624   o = indirect_old_ck_rv2sv(aTHX_ o);
625
626   indirect_map_store(o, pos, sv, CopLINE(&PL_compiling));
627   return o;
628  }
629
630 done:
631  o = indirect_old_ck_rv2sv(aTHX_ o);
632
633  indirect_map_delete(o);
634  return o;
635 }
636
637 /* ... ck_padany ........................................................... */
638
639 STATIC OP *(*indirect_old_ck_padany)(pTHX_ OP *) = 0;
640
641 STATIC OP *indirect_ck_padany(pTHX_ OP *o) {
642  o = indirect_old_ck_padany(aTHX_ o);
643
644  if (indirect_hint()) {
645   SV *sv;
646   const char *s = PL_oldbufptr, *t = PL_bufptr - 1;
647
648   while (s < t && isSPACE(*s)) ++s;
649   if (*s == '$' && ++s <= t) {
650    while (s < t && isSPACE(*s)) ++s;
651    while (s < t && isSPACE(*t)) --t;
652    sv = sv_2mortal(newSVpvn("$", 1));
653    sv_catpvn_nomg(sv, s, t - s + 1);
654    indirect_map_store(o, s - SvPVX_const(PL_linestr),
655                          sv, CopLINE(&PL_compiling));
656    return o;
657   }
658  }
659
660  indirect_map_delete(o);
661  return o;
662 }
663
664 /* ... ck_scope ............................................................ */
665
666 STATIC OP *(*indirect_old_ck_scope)  (pTHX_ OP *) = 0;
667 STATIC OP *(*indirect_old_ck_lineseq)(pTHX_ OP *) = 0;
668
669 STATIC OP *indirect_ck_scope(pTHX_ OP *o) {
670  OP *(*old_ck)(pTHX_ OP *) = 0;
671
672  switch (o->op_type) {
673   case OP_SCOPE:   old_ck = indirect_old_ck_scope;   break;
674   case OP_LINESEQ: old_ck = indirect_old_ck_lineseq; break;
675  }
676  o = old_ck(aTHX_ o);
677
678  if (indirect_hint()) {
679   indirect_map_store(o, PL_oldbufptr - SvPVX_const(PL_linestr),
680                         NULL, CopLINE(&PL_compiling));
681   return o;
682  }
683
684  indirect_map_delete(o);
685  return o;
686 }
687
688 /* We don't need to clean the map entries for leave ops because they can only
689  * be created by mutating from a lineseq. */
690
691 /* ... ck_method ........................................................... */
692
693 STATIC OP *(*indirect_old_ck_method)(pTHX_ OP *) = 0;
694
695 STATIC OP *indirect_ck_method(pTHX_ OP *o) {
696  if (indirect_hint()) {
697   OP *op = cUNOPo->op_first;
698
699   /* Indirect method call is only possible when the method is a bareword, so
700    * don't trip up on $obj->$meth. */
701   if (op && op->op_type == OP_CONST) {
702    const indirect_op_info_t *oi = indirect_map_fetch(op);
703    STRLEN pos;
704    line_t line;
705    SV *sv;
706
707    if (!oi)
708     goto done;
709
710    sv   = sv_2mortal(newSVpvn(oi->buf, oi->len));
711    pos  = oi->pos;
712    /* Keep the old line so that we really point to the first line of the
713     * expression. */
714    line = oi->line;
715
716    o = indirect_old_ck_method(aTHX_ o);
717    /* o may now be a method_named */
718
719    indirect_map_store(o, pos, sv, line);
720    return o;
721   }
722  }
723
724 done:
725  o = indirect_old_ck_method(aTHX_ o);
726
727  indirect_map_delete(o);
728  return o;
729 }
730
731 /* ... ck_method_named ..................................................... */
732
733 /* "use foo/no foo" compiles its call to import/unimport directly to a
734  * method_named op. */
735
736 STATIC OP *(*indirect_old_ck_method_named)(pTHX_ OP *) = 0;
737
738 STATIC OP *indirect_ck_method_named(pTHX_ OP *o) {
739  if (indirect_hint()) {
740   STRLEN pos;
741   line_t line;
742   SV *sv;
743
744   sv = cSVOPo_sv;
745   if (!SvPOK(sv) || (SvTYPE(sv) < SVt_PV))
746    goto done;
747   sv = sv_mortalcopy(sv);
748
749   if (!indirect_find(sv, PL_oldbufptr, &pos))
750    goto done;
751   line = CopLINE(&PL_compiling);
752
753   o = indirect_old_ck_method_named(aTHX_ o);
754
755   indirect_map_store(o, pos, sv, line);
756   return o;
757  }
758
759 done:
760  o = indirect_old_ck_method_named(aTHX_ o);
761
762  indirect_map_delete(o);
763  return o;
764 }
765
766 /* ... ck_entersub ......................................................... */
767
768 STATIC OP *(*indirect_old_ck_entersub)(pTHX_ OP *) = 0;
769
770 STATIC OP *indirect_ck_entersub(pTHX_ OP *o) {
771  SV *code = indirect_hint();
772
773  o = indirect_old_ck_entersub(aTHX_ o);
774
775  if (code) {
776   const indirect_op_info_t *moi, *ooi;
777   OP     *mop, *oop;
778   LISTOP *lop;
779
780   oop = o;
781   do {
782    lop = (LISTOP *) oop;
783    if (!(lop->op_flags & OPf_KIDS))
784     goto done;
785    oop = lop->op_first;
786   } while (oop->op_type != OP_PUSHMARK);
787   oop = oop->op_sibling;
788   mop = lop->op_last;
789
790   if (!oop)
791    goto done;
792
793   switch (oop->op_type) {
794    case OP_CONST:
795    case OP_RV2SV:
796    case OP_PADSV:
797    case OP_SCOPE:
798    case OP_LEAVE:
799     break;
800    default:
801     goto done;
802   }
803
804   if (mop->op_type == OP_METHOD)
805    mop = cUNOPx(mop)->op_first;
806   else if (mop->op_type != OP_METHOD_NAMED)
807    goto done;
808
809   moi = indirect_map_fetch(mop);
810   if (!moi)
811    goto done;
812
813   ooi = indirect_map_fetch(oop);
814   if (!ooi)
815    goto done;
816
817   /* When positions are identical, the method and the object must have the
818    * same name. But it also means that it is an indirect call, as "foo->foo"
819    * results in different positions. */
820   if (   moi->line < ooi->line
821       || (moi->line == ooi->line && moi->pos <= ooi->pos)) {
822    SV *file;
823    dSP;
824
825    ENTER;
826    SAVETMPS;
827
828 #ifdef USE_ITHREADS
829    file = sv_2mortal(newSVpv(CopFILE(&PL_compiling), 0));
830 #else
831    file = sv_mortalcopy(CopFILESV(&PL_compiling));
832 #endif
833
834    PUSHMARK(SP);
835    EXTEND(SP, 4);
836    mPUSHp(ooi->buf, ooi->len);
837    mPUSHp(moi->buf, moi->len);
838    PUSHs(file);
839    mPUSHu(moi->line);
840    PUTBACK;
841
842    call_sv(code, G_VOID);
843
844    PUTBACK;
845
846    FREETMPS;
847    LEAVE;
848   }
849  }
850
851 done:
852  return o;
853 }
854
855 STATIC U32 indirect_initialized = 0;
856
857 STATIC void indirect_teardown(pTHX_ void *root) {
858  if (!indirect_initialized)
859   return;
860
861 #if I_MULTIPLICITY
862  if (aTHX != root)
863   return;
864 #endif
865
866  {
867   dMY_CXT;
868   ptable_free(MY_CXT.map);
869 #if I_THREADSAFE
870   ptable_hints_free(MY_CXT.tbl);
871 #endif
872  }
873
874  PL_check[OP_CONST]           = MEMBER_TO_FPTR(indirect_old_ck_const);
875  indirect_old_ck_const        = 0;
876  PL_check[OP_RV2SV]           = MEMBER_TO_FPTR(indirect_old_ck_rv2sv);
877  indirect_old_ck_rv2sv        = 0;
878  PL_check[OP_PADANY]          = MEMBER_TO_FPTR(indirect_old_ck_padany);
879  indirect_old_ck_padany       = 0;
880  PL_check[OP_SCOPE]           = MEMBER_TO_FPTR(indirect_old_ck_scope);
881  indirect_old_ck_scope        = 0;
882  PL_check[OP_LINESEQ]         = MEMBER_TO_FPTR(indirect_old_ck_lineseq);
883  indirect_old_ck_lineseq      = 0;
884
885  PL_check[OP_METHOD]          = MEMBER_TO_FPTR(indirect_old_ck_method);
886  indirect_old_ck_method       = 0;
887  PL_check[OP_METHOD_NAMED]    = MEMBER_TO_FPTR(indirect_old_ck_method_named);
888  indirect_old_ck_method_named = 0;
889  PL_check[OP_ENTERSUB]        = MEMBER_TO_FPTR(indirect_old_ck_entersub);
890  indirect_old_ck_entersub     = 0;
891
892  indirect_initialized = 0;
893 }
894
895 STATIC void indirect_setup(pTHX) {
896 #define indirect_setup() indirect_setup(aTHX)
897  if (indirect_initialized)
898   return;
899
900  {
901   MY_CXT_INIT;
902 #if I_THREADSAFE
903   MY_CXT.tbl         = ptable_new();
904   MY_CXT.owner       = aTHX;
905 #endif
906   MY_CXT.map         = ptable_new();
907   MY_CXT.global_code = NULL;
908  }
909
910  indirect_old_ck_const        = PL_check[OP_CONST];
911  PL_check[OP_CONST]           = MEMBER_TO_FPTR(indirect_ck_const);
912  indirect_old_ck_rv2sv        = PL_check[OP_RV2SV];
913  PL_check[OP_RV2SV]           = MEMBER_TO_FPTR(indirect_ck_rv2sv);
914  indirect_old_ck_padany       = PL_check[OP_PADANY];
915  PL_check[OP_PADANY]          = MEMBER_TO_FPTR(indirect_ck_padany);
916  indirect_old_ck_scope        = PL_check[OP_SCOPE];
917  PL_check[OP_SCOPE]           = MEMBER_TO_FPTR(indirect_ck_scope);
918  indirect_old_ck_lineseq      = PL_check[OP_LINESEQ];
919  PL_check[OP_LINESEQ]         = MEMBER_TO_FPTR(indirect_ck_scope);
920
921  indirect_old_ck_method       = PL_check[OP_METHOD];
922  PL_check[OP_METHOD]          = MEMBER_TO_FPTR(indirect_ck_method);
923  indirect_old_ck_method_named = PL_check[OP_METHOD_NAMED];
924  PL_check[OP_METHOD_NAMED]    = MEMBER_TO_FPTR(indirect_ck_method_named);
925  indirect_old_ck_entersub     = PL_check[OP_ENTERSUB];
926  PL_check[OP_ENTERSUB]        = MEMBER_TO_FPTR(indirect_ck_entersub);
927
928 #if I_MULTIPLICITY
929  call_atexit(indirect_teardown, aTHX);
930 #else
931  call_atexit(indirect_teardown, NULL);
932 #endif
933
934  indirect_initialized = 1;
935 }
936
937 STATIC U32 indirect_booted = 0;
938
939 /* --- XS ------------------------------------------------------------------ */
940
941 MODULE = indirect      PACKAGE = indirect
942
943 PROTOTYPES: ENABLE
944
945 BOOT:
946 {
947  if (!indirect_booted++) {
948   HV *stash;
949
950   PERL_HASH(indirect_hash, __PACKAGE__, __PACKAGE_LEN__);
951
952   stash = gv_stashpvn(__PACKAGE__, __PACKAGE_LEN__, 1);
953   newCONSTSUB(stash, "I_THREADSAFE", newSVuv(I_THREADSAFE));
954   newCONSTSUB(stash, "I_FORKSAFE",   newSVuv(I_FORKSAFE));
955  }
956
957  indirect_setup();
958 }
959
960 #if I_THREADSAFE
961
962 void
963 CLONE(...)
964 PROTOTYPE: DISABLE
965 PREINIT:
966  ptable *t;
967  SV     *global_code_dup;
968 PPCODE:
969  {
970   my_cxt_t ud;
971   dMY_CXT;
972   ud.tbl   = t = ptable_new();
973   ud.owner = MY_CXT.owner;
974   ptable_walk(MY_CXT.tbl, indirect_ptable_clone, &ud);
975   global_code_dup = indirect_clone(MY_CXT.global_code, MY_CXT.owner);
976  }
977  {
978   MY_CXT_CLONE;
979   MY_CXT.map         = ptable_new();
980   MY_CXT.tbl         = t;
981   MY_CXT.owner       = aTHX;
982   MY_CXT.global_code = global_code_dup;
983  }
984  reap(3, indirect_thread_cleanup, NULL);
985  XSRETURN(0);
986
987 #endif
988
989 SV *
990 _tag(SV *value)
991 PROTOTYPE: $
992 CODE:
993  RETVAL = indirect_tag(value);
994 OUTPUT:
995  RETVAL
996
997 void
998 _global(SV *code)
999 PROTOTYPE: $
1000 PPCODE:
1001  if (!SvOK(code))
1002   code = NULL;
1003  else if (SvROK(code))
1004   code = SvRV(code);
1005  {
1006   dMY_CXT;
1007   SvREFCNT_dec(MY_CXT.global_code);
1008   MY_CXT.global_code = SvREFCNT_inc(code);
1009  }
1010  XSRETURN(0);