485c331a054164995a7b07fb9c9c3e9a7bad2adf
[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 #ifndef OpSIBLING
67 # ifdef OP_SIBLING
68 #  define OpSIBLING(O) OP_SIBLING(O)
69 # else
70 #  define OpSIBLING(O) ((O)->op_sibling)
71 # endif
72 #endif
73
74 #define I_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
75
76 #if I_HAS_PERL(5, 10, 0) || defined(PL_parser)
77 # ifndef PL_linestr
78 #  define PL_linestr PL_parser->linestr
79 # endif
80 # ifndef PL_bufptr
81 #  define PL_bufptr PL_parser->bufptr
82 # endif
83 # ifndef PL_oldbufptr
84 #  define PL_oldbufptr PL_parser->oldbufptr
85 # endif
86 # ifndef PL_lex_inwhat
87 #  define PL_lex_inwhat PL_parser->lex_inwhat
88 # endif
89 #else
90 # ifndef PL_linestr
91 #  define PL_linestr PL_Ilinestr
92 # endif
93 # ifndef PL_bufptr
94 #  define PL_bufptr PL_Ibufptr
95 # endif
96 # ifndef PL_oldbufptr
97 #  define PL_oldbufptr PL_Ioldbufptr
98 # endif
99 # ifndef PL_lex_inwhat
100 #  define PL_lex_inwhat PL_Ilex_inwhat
101 # endif
102 #endif
103
104 #ifndef I_WORKAROUND_REQUIRE_PROPAGATION
105 # define I_WORKAROUND_REQUIRE_PROPAGATION !I_HAS_PERL(5, 10, 1)
106 #endif
107
108 /* ... Thread safety and multiplicity ...................................... */
109
110 /* Safe unless stated otherwise in Makefile.PL */
111 #ifndef I_FORKSAFE
112 # define I_FORKSAFE 1
113 #endif
114
115 #ifndef I_MULTIPLICITY
116 # if defined(MULTIPLICITY)
117 #  define I_MULTIPLICITY 1
118 # else
119 #  define I_MULTIPLICITY 0
120 # endif
121 #endif
122 #if I_MULTIPLICITY
123 # ifndef PERL_IMPLICIT_CONTEXT
124 #  error MULTIPLICITY builds must set PERL_IMPLICIT_CONTEXT
125 # endif
126 #endif
127 #if I_MULTIPLICITY && !defined(tTHX)
128 # define tTHX PerlInterpreter*
129 #endif
130
131 #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))
132 # define I_THREADSAFE 1
133 # ifndef MY_CXT_CLONE
134 #  define MY_CXT_CLONE \
135     dMY_CXT_SV;                                                      \
136     my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1)); \
137     Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t); \
138     sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
139 # endif
140 #else
141 # define I_THREADSAFE 0
142 # undef  dMY_CXT
143 # define dMY_CXT      dNOOP
144 # undef  MY_CXT
145 # define MY_CXT       indirect_globaldata
146 # undef  START_MY_CXT
147 # define START_MY_CXT static my_cxt_t MY_CXT;
148 # undef  MY_CXT_INIT
149 # define MY_CXT_INIT  NOOP
150 # undef  MY_CXT_CLONE
151 # define MY_CXT_CLONE NOOP
152 #endif
153
154 #if defined(OP_CHECK_MUTEX_LOCK) && defined(OP_CHECK_MUTEX_UNLOCK)
155 # define I_CHECK_MUTEX_LOCK   OP_CHECK_MUTEX_LOCK
156 # define I_CHECK_MUTEX_UNLOCK OP_CHECK_MUTEX_UNLOCK
157 #else
158 # define I_CHECK_MUTEX_LOCK   OP_REFCNT_LOCK
159 # define I_CHECK_MUTEX_UNLOCK OP_REFCNT_UNLOCK
160 #endif
161
162 typedef OP *(*indirect_ck_t)(pTHX_ OP *);
163
164 #ifdef wrap_op_checker
165
166 # define indirect_ck_replace(T, NC, OCP) wrap_op_checker((T), (NC), (OCP))
167
168 #else
169
170 static void indirect_ck_replace(pTHX_ OPCODE type, indirect_ck_t new_ck, indirect_ck_t *old_ck_p) {
171 #define indirect_ck_replace(T, NC, OCP) indirect_ck_replace(aTHX_ (T), (NC), (OCP))
172  I_CHECK_MUTEX_LOCK;
173  if (!*old_ck_p) {
174   *old_ck_p      = PL_check[type];
175   PL_check[type] = new_ck;
176  }
177  I_CHECK_MUTEX_UNLOCK;
178 }
179
180 #endif
181
182 static void indirect_ck_restore(pTHX_ OPCODE type, indirect_ck_t *old_ck_p) {
183 #define indirect_ck_restore(T, OCP) indirect_ck_restore(aTHX_ (T), (OCP))
184  I_CHECK_MUTEX_LOCK;
185  if (*old_ck_p) {
186   PL_check[type] = *old_ck_p;
187   *old_ck_p      = 0;
188  }
189  I_CHECK_MUTEX_UNLOCK;
190 }
191
192 /* --- Helpers ------------------------------------------------------------- */
193
194 /* ... Check if the module is loaded ....................................... */
195
196 static U32 indirect_loaded = 0;
197
198 #if I_THREADSAFE
199
200 #define PTABLE_NAME        ptable_loaded
201 #define PTABLE_VAL_FREE(V) NOOP
202
203 #include "ptable.h"
204
205 #define ptable_loaded_store(T, K, V) ptable_loaded_store(aPTBLMS_ (T), (K), (V))
206 #define ptable_loaded_delete(T, K)   ptable_loaded_delete(aPTBLMS_ (T), (K))
207 #define ptable_loaded_free(T)        ptable_loaded_free(aPTBLMS_ (T))
208
209 static ptable *indirect_loaded_cxts = NULL;
210
211 /* We must use preexistent global mutexes or we will never be able to destroy
212  * them. */
213 #if I_HAS_PERL(5, 9, 3)
214 # define I_LOADED_LOCK   MUTEX_LOCK(&PL_my_ctx_mutex)
215 # define I_LOADED_UNLOCK MUTEX_UNLOCK(&PL_my_ctx_mutex)
216 #else
217 # define I_LOADED_LOCK   OP_REFCNT_LOCK
218 # define I_LOADED_UNLOCK OP_REFCNT_UNLOCK
219 #endif
220
221 static int indirect_is_loaded(pTHX_ void *cxt) {
222 #define indirect_is_loaded(C) indirect_is_loaded(aTHX_ (C))
223  int res = 0;
224
225  I_LOADED_LOCK;
226  if (indirect_loaded_cxts && ptable_fetch(indirect_loaded_cxts, cxt))
227   res = 1;
228  I_LOADED_UNLOCK;
229
230  return res;
231 }
232
233 static int indirect_set_loaded_locked(pTHX_ void *cxt) {
234 #define indirect_set_loaded_locked(C) indirect_set_loaded_locked(aTHX_ (C))
235  int global_setup = 0;
236
237  if (indirect_loaded <= 0) {
238   assert(!indirect_loaded_cxts);
239   indirect_loaded_cxts = ptable_new();
240   global_setup         = 1;
241  }
242  ++indirect_loaded;
243  assert(indirect_loaded_cxts);
244  ptable_loaded_store(indirect_loaded_cxts, cxt, cxt);
245
246  return global_setup;
247 }
248
249 static int indirect_clear_loaded_locked(pTHX_ void *cxt) {
250 #define indirect_clear_loaded_locked(C) indirect_clear_loaded_locked(aTHX_ (C))
251  int global_teardown = 0;
252
253  if (indirect_loaded > 1) {
254   assert(indirect_loaded_cxts);
255   ptable_loaded_delete(indirect_loaded_cxts, cxt);
256   --indirect_loaded;
257  } else if (indirect_loaded_cxts) {
258   ptable_loaded_free(indirect_loaded_cxts);
259   indirect_loaded_cxts = NULL;
260   indirect_loaded      = 0;
261   global_teardown      = 1;
262  }
263
264  return global_teardown;
265 }
266
267 #else
268
269 #define I_LOADED_LOCK   NOOP
270 #define I_LOADED_UNLOCK NOOP
271
272 #define indirect_is_loaded(C)           (indirect_loaded > 0)
273 #define indirect_set_loaded_locked(C)   ((indirect_loaded++ <= 0) ? 1 : 0)
274 #define indirect_clear_loaded_locked(C) ((--indirect_loaded <= 0) ? 1 : 0)
275
276 #endif
277
278 /* ... Thread-safe hints ................................................... */
279
280 #if I_WORKAROUND_REQUIRE_PROPAGATION
281
282 typedef struct {
283  SV *code;
284  IV  require_tag;
285 } indirect_hint_t;
286
287 #define I_HINT_STRUCT 1
288
289 #define I_HINT_CODE(H) ((H)->code)
290
291 #define I_HINT_FREE(H) {   \
292  indirect_hint_t *h = (H); \
293  SvREFCNT_dec(h->code);    \
294  PerlMemShared_free(h);    \
295 }
296
297 #else  /*  I_WORKAROUND_REQUIRE_PROPAGATION */
298
299 typedef SV indirect_hint_t;
300
301 #define I_HINT_STRUCT 0
302
303 #define I_HINT_CODE(H) (H)
304
305 #define I_HINT_FREE(H) SvREFCNT_dec(H);
306
307 #endif /* !I_WORKAROUND_REQUIRE_PROPAGATION */
308
309 #if I_THREADSAFE
310
311 #define PTABLE_NAME        ptable_hints
312 #define PTABLE_VAL_FREE(V) I_HINT_FREE(V)
313
314 #define pPTBL  pTHX
315 #define pPTBL_ pTHX_
316 #define aPTBL  aTHX
317 #define aPTBL_ aTHX_
318
319 #include "ptable.h"
320
321 #define ptable_hints_store(T, K, V) ptable_hints_store(aTHX_ (T), (K), (V))
322 #define ptable_hints_free(T)        ptable_hints_free(aTHX_ (T))
323
324 #endif /* I_THREADSAFE */
325
326 /* Define the op->str ptable here because we need to be able to clean it during
327  * thread cleanup. */
328
329 typedef struct {
330  char   *buf;
331  STRLEN  pos;
332  STRLEN  size;
333  STRLEN  len;
334  line_t  line;
335 } indirect_op_info_t;
336
337 #define PTABLE_NAME        ptable
338 #define PTABLE_VAL_FREE(V) if (V) { Safefree(((indirect_op_info_t *) (V))->buf); Safefree(V); }
339
340 #define pPTBL  pTHX
341 #define pPTBL_ pTHX_
342 #define aPTBL  aTHX
343 #define aPTBL_ aTHX_
344
345 #include "ptable.h"
346
347 #define ptable_store(T, K, V) ptable_store(aTHX_ (T), (K), (V))
348 #define ptable_delete(T, K)   ptable_delete(aTHX_ (T), (K))
349 #define ptable_clear(T)       ptable_clear(aTHX_ (T))
350 #define ptable_free(T)        ptable_free(aTHX_ (T))
351
352 #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
353
354 typedef struct {
355 #if I_THREADSAFE
356  ptable *tbl; /* It really is a ptable_hints */
357  tTHX    owner;
358 #endif
359  ptable *map;
360  SV     *global_code;
361 } my_cxt_t;
362
363 START_MY_CXT
364
365 #if I_THREADSAFE
366
367 typedef struct {
368  ptable *tbl;
369 #if I_HAS_PERL(5, 13, 2)
370  CLONE_PARAMS *params;
371 #else
372  CLONE_PARAMS params;
373 #endif
374 } indirect_ptable_clone_ud;
375
376 #if I_HAS_PERL(5, 13, 2)
377 # define indirect_ptable_clone_ud_init(U, T, O) \
378    (U).tbl    = (T); \
379    (U).params = Perl_clone_params_new((O), aTHX)
380 # define indirect_ptable_clone_ud_deinit(U) Perl_clone_params_del((U).params)
381 # define indirect_dup_inc(S, U)             SvREFCNT_inc(sv_dup((S), (U)->params))
382 #else
383 # define indirect_ptable_clone_ud_init(U, T, O) \
384    (U).tbl               = (T);     \
385    (U).params.stashes    = newAV(); \
386    (U).params.flags      = 0;       \
387    (U).params.proto_perl = (O)
388 # define indirect_ptable_clone_ud_deinit(U) SvREFCNT_dec((U).params.stashes)
389 # define indirect_dup_inc(S, U)             SvREFCNT_inc(sv_dup((S), &((U)->params)))
390 #endif
391
392 static void indirect_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) {
393  indirect_ptable_clone_ud *ud = ud_;
394  indirect_hint_t          *h1 = ent->val;
395  indirect_hint_t          *h2;
396
397 #if I_HINT_STRUCT
398
399  h2              = PerlMemShared_malloc(sizeof *h2);
400  h2->code        = indirect_dup_inc(h1->code, ud);
401 #if I_WORKAROUND_REQUIRE_PROPAGATION
402  h2->require_tag = PTR2IV(indirect_dup_inc(INT2PTR(SV *, h1->require_tag), ud));
403 #endif
404
405 #else  /*  I_HINT_STRUCT */
406
407  h2 = indirect_dup_inc(h1, ud);
408
409 #endif /* !I_HINT_STRUCT */
410
411  ptable_hints_store(ud->tbl, ent->key, h2);
412 }
413
414 static void indirect_thread_cleanup(pTHX_ void *ud) {
415  int global_teardown;
416  dMY_CXT;
417
418  global_teardown = indirect_clear_loaded_locked(&MY_CXT);
419  assert(!global_teardown);
420
421  SvREFCNT_dec(MY_CXT.global_code);
422  MY_CXT.global_code = NULL;
423
424  ptable_free(MY_CXT.map);
425  MY_CXT.map = NULL;
426
427  ptable_hints_free(MY_CXT.tbl);
428  MY_CXT.tbl = NULL;
429 }
430
431 static int indirect_endav_free(pTHX_ SV *sv, MAGIC *mg) {
432  SAVEDESTRUCTOR_X(indirect_thread_cleanup, NULL);
433
434  return 0;
435 }
436
437 static MGVTBL indirect_endav_vtbl = {
438  0,
439  0,
440  0,
441  0,
442  indirect_endav_free
443 #if MGf_COPY
444  , 0
445 #endif
446 #if MGf_DUP
447  , 0
448 #endif
449 #if MGf_LOCAL
450  , 0
451 #endif
452 };
453
454 #endif /* I_THREADSAFE */
455
456 #if I_WORKAROUND_REQUIRE_PROPAGATION
457 static IV indirect_require_tag(pTHX) {
458 #define indirect_require_tag() indirect_require_tag(aTHX)
459  const CV *cv, *outside;
460
461  cv = PL_compcv;
462
463  if (!cv) {
464   /* If for some reason the pragma is operational at run-time, try to discover
465    * the current cv in use. */
466   const PERL_SI *si;
467
468   for (si = PL_curstackinfo; si; si = si->si_prev) {
469    I32 cxix;
470
471    for (cxix = si->si_cxix; cxix >= 0; --cxix) {
472     const PERL_CONTEXT *cx = si->si_cxstack + cxix;
473
474     switch (CxTYPE(cx)) {
475      case CXt_SUB:
476      case CXt_FORMAT:
477       /* The propagation workaround is only needed up to 5.10.0 and at that
478        * time format and sub contexts were still identical. And even later the
479        * cv members offsets should have been kept the same. */
480       cv = cx->blk_sub.cv;
481       goto get_enclosing_cv;
482      case CXt_EVAL:
483       cv = cx->blk_eval.cv;
484       goto get_enclosing_cv;
485      default:
486       break;
487     }
488    }
489   }
490
491   cv = PL_main_cv;
492  }
493
494 get_enclosing_cv:
495  for (outside = CvOUTSIDE(cv); outside; outside = CvOUTSIDE(cv))
496   cv = outside;
497
498  return PTR2IV(cv);
499 }
500 #endif /* I_WORKAROUND_REQUIRE_PROPAGATION */
501
502 static SV *indirect_tag(pTHX_ SV *value) {
503 #define indirect_tag(V) indirect_tag(aTHX_ (V))
504  indirect_hint_t *h;
505  SV              *code = NULL;
506 #if I_THREADSAFE
507  dMY_CXT;
508
509  if (!MY_CXT.tbl)
510   return newSViv(0);
511 #endif /* I_THREADSAFE */
512
513  if (SvROK(value)) {
514   value = SvRV(value);
515   if (SvTYPE(value) >= SVt_PVCV) {
516    code = value;
517    SvREFCNT_inc_simple_void_NN(code);
518   }
519  }
520
521 #if I_HINT_STRUCT
522  h = PerlMemShared_malloc(sizeof *h);
523  h->code        = code;
524 # if I_WORKAROUND_REQUIRE_PROPAGATION
525  h->require_tag = indirect_require_tag();
526 # endif /* I_WORKAROUND_REQUIRE_PROPAGATION */
527 #else  /*  I_HINT_STRUCT */
528  h = code;
529 #endif /* !I_HINT_STRUCT */
530
531 #if I_THREADSAFE
532  /* We only need for the key to be an unique tag for looking up the value later
533   * Allocated memory provides convenient unique identifiers, so that's why we
534   * use the hint as the key itself. */
535  ptable_hints_store(MY_CXT.tbl, h, h);
536 #endif /* I_THREADSAFE */
537
538  return newSViv(PTR2IV(h));
539 }
540
541 static SV *indirect_detag(pTHX_ const SV *hint) {
542 #define indirect_detag(H) indirect_detag(aTHX_ (H))
543  indirect_hint_t *h;
544 #if I_THREADSAFE || I_WORKAROUND_REQUIRE_PROPAGATION
545  dMY_CXT;
546 #endif
547
548 #if I_THREADSAFE
549  if (!MY_CXT.tbl)
550   return NULL;
551 #endif /* I_THREADSAFE */
552
553  h = INT2PTR(indirect_hint_t *, SvIVX(hint));
554 #if I_THREADSAFE
555  h = ptable_fetch(MY_CXT.tbl, h);
556 #endif /* I_THREADSAFE */
557
558 #if I_WORKAROUND_REQUIRE_PROPAGATION
559  if (indirect_require_tag() != h->require_tag)
560   return MY_CXT.global_code;
561 #endif /* I_WORKAROUND_REQUIRE_PROPAGATION */
562
563  return I_HINT_CODE(h);
564 }
565
566 static VOL U32 indirect_hash = 0;
567
568 static SV *indirect_hint(pTHX) {
569 #define indirect_hint() indirect_hint(aTHX)
570  SV *hint = NULL;
571
572  if (IN_PERL_RUNTIME)
573   return NULL;
574
575 #if I_HAS_PERL(5, 10, 0) || defined(PL_parser)
576  if (!PL_parser)
577   return NULL;
578 #endif
579
580 #ifdef cop_hints_fetch_pvn
581  hint = cop_hints_fetch_pvn(PL_curcop, __PACKAGE__, __PACKAGE_LEN__,
582                                                               indirect_hash, 0);
583 #elif I_HAS_PERL(5, 9, 5)
584  hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
585                                        NULL,
586                                        __PACKAGE__, __PACKAGE_LEN__,
587                                        0,
588                                        indirect_hash);
589 #else
590  {
591   SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__, 0);
592   if (val)
593    hint = *val;
594  }
595 #endif
596
597  if (hint && SvIOK(hint)) {
598   return indirect_detag(hint);
599  } else {
600   dMY_CXT;
601   if (indirect_is_loaded(&MY_CXT))
602    return MY_CXT.global_code;
603   else
604    return NULL;
605  }
606 }
607
608 /* ... op -> source position ............................................... */
609
610 static void indirect_map_store(pTHX_ const OP *o, STRLEN pos, SV *sv, line_t line) {
611 #define indirect_map_store(O, P, N, L) indirect_map_store(aTHX_ (O), (P), (N), (L))
612  indirect_op_info_t *oi;
613  const char *s;
614  STRLEN len;
615  dMY_CXT;
616
617  /* No need to check for MY_CXT.map != NULL because this code path is always
618   * guarded by indirect_hint(). */
619
620  if (!(oi = ptable_fetch(MY_CXT.map, o))) {
621   Newx(oi, 1, indirect_op_info_t);
622   ptable_store(MY_CXT.map, o, oi);
623   oi->buf  = NULL;
624   oi->size = 0;
625  }
626
627  if (sv) {
628   s = SvPV_const(sv, len);
629  } else {
630   s   = "{";
631   len = 1;
632  }
633
634  if (len > oi->size) {
635   Safefree(oi->buf);
636   Newx(oi->buf, len, char);
637   oi->size = len;
638  }
639  Copy(s, oi->buf, len, char);
640
641  oi->len  = len;
642  oi->pos  = pos;
643  oi->line = line;
644 }
645
646 static const indirect_op_info_t *indirect_map_fetch(pTHX_ const OP *o) {
647 #define indirect_map_fetch(O) indirect_map_fetch(aTHX_ (O))
648  dMY_CXT;
649
650  /* No need to check for MY_CXT.map != NULL because this code path is always
651   * guarded by indirect_hint(). */
652
653  return ptable_fetch(MY_CXT.map, o);
654 }
655
656 static void indirect_map_delete(pTHX_ const OP *o) {
657 #define indirect_map_delete(O) indirect_map_delete(aTHX_ (O))
658  dMY_CXT;
659
660  if (indirect_is_loaded(&MY_CXT) && MY_CXT.map)
661   ptable_delete(MY_CXT.map, o);
662 }
663
664 /* --- Check functions ----------------------------------------------------- */
665
666 static int indirect_find(pTHX_ SV *name_sv, const char *line_bufptr, STRLEN *name_pos) {
667 #define indirect_find(NSV, LBP, NP) indirect_find(aTHX_ (NSV), (LBP), (NP))
668  STRLEN      name_len, line_len;
669  const char *name, *name_end;
670  const char *line, *line_end;
671  const char *p;
672
673  line     = SvPV_const(PL_linestr, line_len);
674  line_end = line + line_len;
675
676  name = SvPV_const(name_sv, name_len);
677  if (name_len >= 1 && *name == '$') {
678   ++name;
679   --name_len;
680   while (line_bufptr < line_end && *line_bufptr != '$')
681    ++line_bufptr;
682   if (line_bufptr >= line_end)
683    return 0;
684  }
685  name_end = name + name_len;
686
687  p = line_bufptr;
688  while (1) {
689   p = ninstr(p, line_end, name, name_end);
690   if (!p)
691    return 0;
692   if (!isALNUM(p[name_len]))
693    break;
694   /* p points to a word that has name as prefix, skip the rest of the word */
695   p += name_len + 1;
696   while (isALNUM(*p))
697    ++p;
698  }
699
700  *name_pos = p - line;
701
702  return 1;
703 }
704
705 /* ... ck_const ............................................................ */
706
707 static OP *(*indirect_old_ck_const)(pTHX_ OP *) = 0;
708
709 static OP *indirect_ck_const(pTHX_ OP *o) {
710  o = indirect_old_ck_const(aTHX_ o);
711
712  if (indirect_hint()) {
713   SV *sv = cSVOPo_sv;
714
715   if (SvPOK(sv) && (SvTYPE(sv) >= SVt_PV)) {
716    STRLEN pos;
717
718    if (indirect_find(sv, PL_oldbufptr, &pos)) {
719     STRLEN len;
720
721     /* If the constant is equal to the current package name, try to look for
722      * a "__PACKAGE__" coming before what we got. We only need to check this
723      * when we already had a match because __PACKAGE__ can only appear in
724      * direct method calls ("new __PACKAGE__" is a syntax error). */
725     len = SvCUR(sv);
726     if (PL_curstash
727         && len == (STRLEN) HvNAMELEN_get(PL_curstash)
728         && memcmp(SvPVX(sv), HvNAME_get(PL_curstash), len) == 0) {
729      STRLEN pos_pkg;
730      SV    *pkg = sv_newmortal();
731      sv_setpvn(pkg, "__PACKAGE__", sizeof("__PACKAGE__")-1);
732
733      if (indirect_find(pkg, PL_oldbufptr, &pos_pkg) && pos_pkg < pos) {
734       sv  = pkg;
735       pos = pos_pkg;
736      }
737     }
738
739     indirect_map_store(o, pos, sv, CopLINE(&PL_compiling));
740     return o;
741    }
742   }
743  }
744
745  indirect_map_delete(o);
746  return o;
747 }
748
749 /* ... ck_rv2sv ............................................................ */
750
751 static OP *(*indirect_old_ck_rv2sv)(pTHX_ OP *) = 0;
752
753 static OP *indirect_ck_rv2sv(pTHX_ OP *o) {
754  if (indirect_hint()) {
755   OP *op = cUNOPo->op_first;
756   SV *sv;
757   const char *name = NULL;
758   STRLEN pos, len;
759   OPCODE type = (OPCODE) op->op_type;
760
761   switch (type) {
762    case OP_GV:
763    case OP_GVSV: {
764     GV *gv = cGVOPx_gv(op);
765     name = GvNAME(gv);
766     len  = GvNAMELEN(gv);
767     break;
768    }
769    default:
770     if ((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP) {
771      SV *nsv = cSVOPx_sv(op);
772      if (SvPOK(nsv) && (SvTYPE(nsv) >= SVt_PV))
773       name = SvPV_const(nsv, len);
774     }
775   }
776   if (!name)
777    goto done;
778
779   sv = sv_2mortal(newSVpvn("$", 1));
780   sv_catpvn_nomg(sv, name, len);
781   if (!indirect_find(sv, PL_oldbufptr, &pos)) {
782    /* If it failed, retry without the current stash */
783    const char *stash = HvNAME_get(PL_curstash);
784    STRLEN stashlen = HvNAMELEN_get(PL_curstash);
785
786    if ((len < stashlen + 2) || strnNE(name, stash, stashlen)
787        || name[stashlen] != ':' || name[stashlen+1] != ':') {
788     /* Failed again ? Try to remove main */
789     stash = "main";
790     stashlen = 4;
791     if ((len < stashlen + 2) || strnNE(name, stash, stashlen)
792         || name[stashlen] != ':' || name[stashlen+1] != ':')
793      goto done;
794    }
795
796    sv_setpvn(sv, "$", 1);
797    stashlen += 2;
798    sv_catpvn_nomg(sv, name + stashlen, len - stashlen);
799    if (!indirect_find(sv, PL_oldbufptr, &pos))
800     goto done;
801   }
802
803   o = indirect_old_ck_rv2sv(aTHX_ o);
804
805   indirect_map_store(o, pos, sv, CopLINE(&PL_compiling));
806   return o;
807  }
808
809 done:
810  o = indirect_old_ck_rv2sv(aTHX_ o);
811
812  indirect_map_delete(o);
813  return o;
814 }
815
816 /* ... ck_padany ........................................................... */
817
818 static OP *(*indirect_old_ck_padany)(pTHX_ OP *) = 0;
819
820 static OP *indirect_ck_padany(pTHX_ OP *o) {
821  o = indirect_old_ck_padany(aTHX_ o);
822
823  if (indirect_hint()) {
824   SV *sv;
825   const char *s = PL_oldbufptr, *t = PL_bufptr - 1;
826
827   while (s < t && isSPACE(*s)) ++s;
828   if (*s == '$' && ++s <= t) {
829    while (s < t && isSPACE(*s)) ++s;
830    while (s < t && isSPACE(*t)) --t;
831    sv = sv_2mortal(newSVpvn("$", 1));
832    sv_catpvn_nomg(sv, s, t - s + 1);
833    indirect_map_store(o, s - SvPVX_const(PL_linestr),
834                          sv, CopLINE(&PL_compiling));
835    return o;
836   }
837  }
838
839  indirect_map_delete(o);
840  return o;
841 }
842
843 /* ... ck_scope ............................................................ */
844
845 static OP *(*indirect_old_ck_scope)  (pTHX_ OP *) = 0;
846 static OP *(*indirect_old_ck_lineseq)(pTHX_ OP *) = 0;
847
848 static OP *indirect_ck_scope(pTHX_ OP *o) {
849  OP *(*old_ck)(pTHX_ OP *) = 0;
850
851  switch (o->op_type) {
852   case OP_SCOPE:   old_ck = indirect_old_ck_scope;   break;
853   case OP_LINESEQ: old_ck = indirect_old_ck_lineseq; break;
854  }
855  o = old_ck(aTHX_ o);
856
857  if (indirect_hint()) {
858   indirect_map_store(o, PL_oldbufptr - SvPVX_const(PL_linestr),
859                         NULL, CopLINE(&PL_compiling));
860   return o;
861  }
862
863  indirect_map_delete(o);
864  return o;
865 }
866
867 /* We don't need to clean the map entries for leave ops because they can only
868  * be created by mutating from a lineseq. */
869
870 /* ... ck_method ........................................................... */
871
872 static OP *(*indirect_old_ck_method)(pTHX_ OP *) = 0;
873
874 static OP *indirect_ck_method(pTHX_ OP *o) {
875  if (indirect_hint()) {
876   OP *op = cUNOPo->op_first;
877
878   /* Indirect method call is only possible when the method is a bareword, so
879    * don't trip up on $obj->$meth. */
880   if (op && op->op_type == OP_CONST) {
881    const indirect_op_info_t *oi = indirect_map_fetch(op);
882    STRLEN pos;
883    line_t line;
884    SV *sv;
885
886    if (!oi)
887     goto done;
888
889    sv   = sv_2mortal(newSVpvn(oi->buf, oi->len));
890    pos  = oi->pos;
891    /* Keep the old line so that we really point to the first line of the
892     * expression. */
893    line = oi->line;
894
895    o = indirect_old_ck_method(aTHX_ o);
896    /* o may now be a method_named */
897
898    indirect_map_store(o, pos, sv, line);
899    return o;
900   }
901  }
902
903 done:
904  o = indirect_old_ck_method(aTHX_ o);
905
906  indirect_map_delete(o);
907  return o;
908 }
909
910 /* ... ck_method_named ..................................................... */
911
912 /* "use foo/no foo" compiles its call to import/unimport directly to a
913  * method_named op. */
914
915 static OP *(*indirect_old_ck_method_named)(pTHX_ OP *) = 0;
916
917 static OP *indirect_ck_method_named(pTHX_ OP *o) {
918  if (indirect_hint()) {
919   STRLEN pos;
920   line_t line;
921   SV *sv;
922
923   sv = cSVOPo_sv;
924   if (!SvPOK(sv) || (SvTYPE(sv) < SVt_PV))
925    goto done;
926   sv = sv_mortalcopy(sv);
927
928   if (!indirect_find(sv, PL_oldbufptr, &pos))
929    goto done;
930   line = CopLINE(&PL_compiling);
931
932   o = indirect_old_ck_method_named(aTHX_ o);
933
934   indirect_map_store(o, pos, sv, line);
935   return o;
936  }
937
938 done:
939  o = indirect_old_ck_method_named(aTHX_ o);
940
941  indirect_map_delete(o);
942  return o;
943 }
944
945 /* ... ck_entersub ......................................................... */
946
947 static OP *(*indirect_old_ck_entersub)(pTHX_ OP *) = 0;
948
949 static OP *indirect_ck_entersub(pTHX_ OP *o) {
950  SV *code = indirect_hint();
951
952  o = indirect_old_ck_entersub(aTHX_ o);
953
954  if (code) {
955   const indirect_op_info_t *moi, *ooi;
956   OP     *mop, *oop;
957   LISTOP *lop;
958
959   oop = o;
960   do {
961    lop = (LISTOP *) oop;
962    if (!(lop->op_flags & OPf_KIDS))
963     goto done;
964    oop = lop->op_first;
965   } while (oop->op_type != OP_PUSHMARK);
966   oop = OpSIBLING(oop);
967   mop = lop->op_last;
968
969   if (!oop)
970    goto done;
971
972   switch (oop->op_type) {
973    case OP_CONST:
974    case OP_RV2SV:
975    case OP_PADSV:
976    case OP_SCOPE:
977    case OP_LEAVE:
978     break;
979    default:
980     goto done;
981   }
982
983   if (mop->op_type == OP_METHOD)
984    mop = cUNOPx(mop)->op_first;
985   else if (mop->op_type != OP_METHOD_NAMED)
986    goto done;
987
988   moi = indirect_map_fetch(mop);
989   if (!moi)
990    goto done;
991
992   ooi = indirect_map_fetch(oop);
993   if (!ooi)
994    goto done;
995
996   /* When positions are identical, the method and the object must have the
997    * same name. But it also means that it is an indirect call, as "foo->foo"
998    * results in different positions. */
999   if (   moi->line < ooi->line
1000       || (moi->line == ooi->line && moi->pos <= ooi->pos)) {
1001    SV *file;
1002    dSP;
1003
1004    ENTER;
1005    SAVETMPS;
1006
1007 #ifdef USE_ITHREADS
1008    file = sv_2mortal(newSVpv(CopFILE(&PL_compiling), 0));
1009 #else
1010    file = sv_mortalcopy(CopFILESV(&PL_compiling));
1011 #endif
1012
1013    PUSHMARK(SP);
1014    EXTEND(SP, 4);
1015    mPUSHp(ooi->buf, ooi->len);
1016    mPUSHp(moi->buf, moi->len);
1017    PUSHs(file);
1018    mPUSHu(moi->line);
1019    PUTBACK;
1020
1021    call_sv(code, G_VOID);
1022
1023    PUTBACK;
1024
1025    FREETMPS;
1026    LEAVE;
1027   }
1028  }
1029
1030 done:
1031  return o;
1032 }
1033
1034 /* --- Module setup/teardown ----------------------------------------------- */
1035
1036 static void indirect_teardown(pTHX_ void *interp) {
1037  dMY_CXT;
1038
1039 #if I_MULTIPLICITY
1040  if (aTHX != interp)
1041   return;
1042 #endif
1043
1044  I_LOADED_LOCK;
1045
1046  if (indirect_clear_loaded_locked(&MY_CXT)) {
1047   indirect_ck_restore(OP_CONST,   &indirect_old_ck_const);
1048   indirect_ck_restore(OP_RV2SV,   &indirect_old_ck_rv2sv);
1049   indirect_ck_restore(OP_PADANY,  &indirect_old_ck_padany);
1050   indirect_ck_restore(OP_SCOPE,   &indirect_old_ck_scope);
1051   indirect_ck_restore(OP_LINESEQ, &indirect_old_ck_lineseq);
1052
1053   indirect_ck_restore(OP_METHOD,       &indirect_old_ck_method);
1054   indirect_ck_restore(OP_METHOD_NAMED, &indirect_old_ck_method_named);
1055   indirect_ck_restore(OP_ENTERSUB,     &indirect_old_ck_entersub);
1056  }
1057
1058  I_LOADED_UNLOCK;
1059
1060  ptable_free(MY_CXT.map);
1061  MY_CXT.map = NULL;
1062
1063 #if I_THREADSAFE
1064  ptable_hints_free(MY_CXT.tbl);
1065  MY_CXT.tbl = NULL;
1066 #endif
1067
1068  return;
1069 }
1070
1071 static void indirect_setup(pTHX) {
1072 #define indirect_setup() indirect_setup(aTHX)
1073  MY_CXT_INIT; /* Takes/release PL_my_ctx_mutex */
1074
1075  I_LOADED_LOCK;
1076
1077  if (indirect_set_loaded_locked(&MY_CXT)) {
1078   PERL_HASH(indirect_hash, __PACKAGE__, __PACKAGE_LEN__);
1079
1080   indirect_ck_replace(OP_CONST,   indirect_ck_const,  &indirect_old_ck_const);
1081   indirect_ck_replace(OP_RV2SV,   indirect_ck_rv2sv,  &indirect_old_ck_rv2sv);
1082   indirect_ck_replace(OP_PADANY,  indirect_ck_padany, &indirect_old_ck_padany);
1083   indirect_ck_replace(OP_SCOPE,   indirect_ck_scope,  &indirect_old_ck_scope);
1084   indirect_ck_replace(OP_LINESEQ, indirect_ck_scope,  &indirect_old_ck_lineseq);
1085
1086   indirect_ck_replace(OP_METHOD,       indirect_ck_method,
1087                                        &indirect_old_ck_method);
1088   indirect_ck_replace(OP_METHOD_NAMED, indirect_ck_method_named,
1089                                        &indirect_old_ck_method_named);
1090   indirect_ck_replace(OP_ENTERSUB,     indirect_ck_entersub,
1091                                        &indirect_old_ck_entersub);
1092  }
1093
1094  I_LOADED_UNLOCK;
1095
1096  {
1097   HV *stash;
1098
1099   stash = gv_stashpvn(__PACKAGE__, __PACKAGE_LEN__, 1);
1100   newCONSTSUB(stash, "I_THREADSAFE", newSVuv(I_THREADSAFE));
1101   newCONSTSUB(stash, "I_FORKSAFE",   newSVuv(I_FORKSAFE));
1102
1103 #if I_THREADSAFE
1104   MY_CXT.tbl         = ptable_new();
1105   MY_CXT.owner       = aTHX;
1106 #endif
1107
1108   MY_CXT.map         = ptable_new();
1109   MY_CXT.global_code = NULL;
1110  }
1111
1112 #if I_MULTIPLICITY
1113  call_atexit(indirect_teardown, aTHX);
1114 #else
1115  call_atexit(indirect_teardown, NULL);
1116 #endif
1117
1118  return;
1119 }
1120
1121 /* --- XS ------------------------------------------------------------------ */
1122
1123 MODULE = indirect      PACKAGE = indirect
1124
1125 PROTOTYPES: ENABLE
1126
1127 BOOT:
1128 {
1129  indirect_setup();
1130 }
1131
1132 #if I_THREADSAFE
1133
1134 void
1135 CLONE(...)
1136 PROTOTYPE: DISABLE
1137 PREINIT:
1138  ptable *t;
1139  SV     *global_code_dup;
1140  GV     *gv;
1141 PPCODE:
1142  {
1143   indirect_ptable_clone_ud ud;
1144   dMY_CXT;
1145   t = ptable_new();
1146   indirect_ptable_clone_ud_init(ud, t, MY_CXT.owner);
1147   ptable_walk(MY_CXT.tbl, indirect_ptable_clone, &ud);
1148   global_code_dup = indirect_dup_inc(MY_CXT.global_code, &ud);
1149   indirect_ptable_clone_ud_deinit(ud);
1150  }
1151  {
1152   MY_CXT_CLONE;
1153   MY_CXT.map         = ptable_new();
1154   MY_CXT.tbl         = t;
1155   MY_CXT.owner       = aTHX;
1156   MY_CXT.global_code = global_code_dup;
1157   {
1158    int global_setup;
1159    I_LOADED_LOCK;
1160    global_setup = indirect_set_loaded_locked(&MY_CXT);
1161    assert(!global_setup);
1162    I_LOADED_UNLOCK;
1163   }
1164  }
1165  gv = gv_fetchpv(__PACKAGE__ "::_THREAD_CLEANUP", 0, SVt_PVCV);
1166  if (gv) {
1167   CV *cv = GvCV(gv);
1168   if (!PL_endav)
1169    PL_endav = newAV();
1170   SvREFCNT_inc(cv);
1171   if (!av_store(PL_endav, av_len(PL_endav) + 1, (SV *) cv))
1172    SvREFCNT_dec(cv);
1173   sv_magicext((SV *) PL_endav, NULL, PERL_MAGIC_ext, &indirect_endav_vtbl, NULL, 0);
1174  }
1175  XSRETURN(0);
1176
1177 void
1178 _THREAD_CLEANUP(...)
1179 PROTOTYPE: DISABLE
1180 PPCODE:
1181  indirect_thread_cleanup(aTHX_ NULL);
1182  XSRETURN(0);
1183
1184 #endif
1185
1186 SV *
1187 _tag(SV *value)
1188 PROTOTYPE: $
1189 CODE:
1190  RETVAL = indirect_tag(value);
1191 OUTPUT:
1192  RETVAL
1193
1194 void
1195 _global(SV *code)
1196 PROTOTYPE: $
1197 PPCODE:
1198  if (!SvOK(code))
1199   code = NULL;
1200  else if (SvROK(code))
1201   code = SvRV(code);
1202  {
1203   dMY_CXT;
1204   SvREFCNT_dec(MY_CXT.global_code);
1205   MY_CXT.global_code = SvREFCNT_inc(code);
1206  }
1207  XSRETURN(0);