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