8e6c789b1b0098315650bf8b05193aac0eb0c77e
[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_lex_inwhat
66 #  define PL_lex_inwhat PL_parser->lex_inwhat
67 # endif
68 # ifndef PL_linestr
69 #  define PL_linestr PL_parser->linestr
70 # endif
71 # ifndef PL_bufptr
72 #  define PL_bufptr PL_parser->bufptr
73 # endif
74 # ifndef PL_oldbufptr
75 #  define PL_oldbufptr PL_parser->oldbufptr
76 # endif
77 #else
78 # ifndef PL_lex_inwhat
79 #  define PL_lex_inwhat PL_Ilex_inwhat
80 # endif
81 # ifndef PL_linestr
82 #  define PL_linestr PL_Ilinestr
83 # endif
84 # ifndef PL_bufptr
85 #  define PL_bufptr PL_Ibufptr
86 # endif
87 # ifndef PL_oldbufptr
88 #  define PL_oldbufptr PL_Ioldbufptr
89 # endif
90 #endif
91
92 #ifndef I_WORKAROUND_REQUIRE_PROPAGATION
93 # define I_WORKAROUND_REQUIRE_PROPAGATION !I_HAS_PERL(5, 10, 1)
94 #endif
95
96 /* ... Thread safety and multiplicity ...................................... */
97
98 #ifndef I_MULTIPLICITY
99 # if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT)
100 #  define I_MULTIPLICITY 1
101 # else
102 #  define I_MULTIPLICITY 0
103 # endif
104 #endif
105 #if I_MULTIPLICITY && !defined(tTHX)
106 # define tTHX PerlInterpreter*
107 #endif
108
109 #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))
110 # define I_THREADSAFE 1
111 # ifndef MY_CXT_CLONE
112 #  define MY_CXT_CLONE \
113     dMY_CXT_SV;                                                      \
114     my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1)); \
115     Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t); \
116     sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
117 # endif
118 #else
119 # define I_THREADSAFE 0
120 # undef  dMY_CXT
121 # define dMY_CXT      dNOOP
122 # undef  MY_CXT
123 # define MY_CXT       indirect_globaldata
124 # undef  START_MY_CXT
125 # define START_MY_CXT STATIC my_cxt_t MY_CXT;
126 # undef  MY_CXT_INIT
127 # define MY_CXT_INIT  NOOP
128 # undef  MY_CXT_CLONE
129 # define MY_CXT_CLONE NOOP
130 #endif
131
132 /* --- Helpers ------------------------------------------------------------- */
133
134 /* ... Thread-safe hints ................................................... */
135
136 /* If any of those are true, we need to store the hint in a global table. */
137
138 #if I_THREADSAFE || I_WORKAROUND_REQUIRE_PROPAGATION
139
140 typedef struct {
141  SV  *code;
142 #if I_WORKAROUND_REQUIRE_PROPAGATION
143  I32  requires;
144 #endif
145 } indirect_hint_t;
146
147 #define PTABLE_NAME ptable_hints
148
149 #define PTABLE_VAL_FREE(V) \
150    { indirect_hint_t *h = (V); SvREFCNT_dec(h->code); PerlMemShared_free(h); }
151
152 #define pPTBL  pTHX
153 #define pPTBL_ pTHX_
154 #define aPTBL  aTHX
155 #define aPTBL_ aTHX_
156
157 #include "ptable.h"
158
159 #define ptable_hints_store(T, K, V) ptable_hints_store(aTHX_ (T), (K), (V))
160 #define ptable_hints_free(T)        ptable_hints_free(aTHX_ (T))
161
162 #endif /* I_THREADSAFE || I_WORKAROUND_REQUIRE_PROPAGATION */
163
164 /* Define the op->str ptable here because we need to be able to clean it during
165  * thread cleanup. */
166
167 typedef struct {
168  const char *pos;
169  char       *buf;
170  STRLEN      len, size;
171  line_t      line;
172 } indirect_op_info_t;
173
174 #define PTABLE_NAME        ptable
175 #define PTABLE_VAL_FREE(V) if (V) { Safefree(((indirect_op_info_t *) (V))->buf); Safefree(V); }
176
177 #define pPTBL  pTHX
178 #define pPTBL_ pTHX_
179 #define aPTBL  aTHX
180 #define aPTBL_ aTHX_
181
182 #include "ptable.h"
183
184 #define ptable_store(T, K, V) ptable_store(aTHX_ (T), (K), (V))
185 #define ptable_clear(T)       ptable_clear(aTHX_ (T))
186 #define ptable_free(T)        ptable_free(aTHX_ (T))
187
188 #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
189
190 typedef struct {
191 #if I_THREADSAFE || I_WORKAROUND_REQUIRE_PROPAGATION
192  ptable     *tbl; /* It really is a ptable_hints */
193 #endif
194  ptable     *map;
195  const char *linestr;
196 #if I_THREADSAFE
197  tTHX        owner;
198 #endif
199 } my_cxt_t;
200
201 START_MY_CXT
202
203 #if I_THREADSAFE
204
205 STATIC SV *indirect_clone(pTHX_ SV *sv, tTHX owner) {
206 #define indirect_clone(S, O) indirect_clone(aTHX_ (S), (O))
207  CLONE_PARAMS  param;
208  AV           *stashes = NULL;
209  SV           *dupsv;
210
211  if (SvTYPE(sv) == SVt_PVHV && HvNAME_get(sv))
212   stashes = newAV();
213
214  param.stashes    = stashes;
215  param.flags      = 0;
216  param.proto_perl = owner;
217
218  dupsv = sv_dup(sv, &param);
219
220  if (stashes) {
221   av_undef(stashes);
222   SvREFCNT_dec(stashes);
223  }
224
225  return SvREFCNT_inc(dupsv);
226 }
227
228 STATIC void indirect_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) {
229  my_cxt_t        *ud = ud_;
230  indirect_hint_t *h1 = ent->val;
231  indirect_hint_t *h2 = PerlMemShared_malloc(sizeof *h2);
232
233  *h2 = *h1;
234
235  if (ud->owner != aTHX)
236   h2->code = indirect_clone(h1->code, ud->owner);
237
238  ptable_hints_store(ud->tbl, ent->key, h2);
239  SvREFCNT_inc(h2->code);
240 }
241
242 STATIC void indirect_thread_cleanup(pTHX_ void *);
243
244 STATIC void indirect_thread_cleanup(pTHX_ void *ud) {
245  int *level = ud;
246
247  if (*level) {
248   *level = 0;
249   LEAVE;
250   SAVEDESTRUCTOR_X(indirect_thread_cleanup, level);
251   ENTER;
252  } else {
253   dMY_CXT;
254   PerlMemShared_free(level);
255   ptable_free(MY_CXT.map);
256   ptable_hints_free(MY_CXT.tbl);
257  }
258 }
259
260 #endif /* I_THREADSAFE */
261
262 #if I_THREADSAFE || I_WORKAROUND_REQUIRE_PROPAGATION
263
264 STATIC SV *indirect_tag(pTHX_ SV *value) {
265 #define indirect_tag(V) indirect_tag(aTHX_ (V))
266  indirect_hint_t *h;
267  SV *code = NULL;
268  dMY_CXT;
269
270  if (SvOK(value) && SvROK(value)) {
271   value = SvRV(value);
272   if (SvTYPE(value) >= SVt_PVCV) {
273    code = value;
274    if (CvANON(code) && !CvCLONED(code))
275     CvCLONE_on(code);
276    SvREFCNT_inc_simple_NN(code);
277   }
278  }
279
280  h = PerlMemShared_malloc(sizeof *h);
281  h->code = code;
282
283 #if I_WORKAROUND_REQUIRE_PROPAGATION
284  {
285   const PERL_SI *si;
286   I32            requires = 0;
287
288   for (si = PL_curstackinfo; si; si = si->si_prev) {
289    I32 cxix;
290
291    for (cxix = si->si_cxix; cxix >= 0; --cxix) {
292     const PERL_CONTEXT *cx = si->si_cxstack + cxix;
293
294     if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_REQUIRE)
295      ++requires;
296    }
297   }
298
299   h->requires = requires;
300  }
301 #endif
302
303  /* We only need for the key to be an unique tag for looking up the value later.
304   * Allocated memory provides convenient unique identifiers, so that's why we
305   * use the value pointer as the key itself. */
306  ptable_hints_store(MY_CXT.tbl, value, h);
307
308  return newSVuv(PTR2UV(value));
309 }
310
311 STATIC SV *indirect_detag(pTHX_ const SV *hint) {
312 #define indirect_detag(H) indirect_detag(aTHX_ (H))
313  indirect_hint_t *h;
314  dMY_CXT;
315
316  if (!(hint && SvOK(hint) && SvIOK(hint)))
317   return NULL;
318
319  h = ptable_fetch(MY_CXT.tbl, INT2PTR(void *, SvUVX(hint)));
320
321 #if I_WORKAROUND_REQUIRE_PROPAGATION
322  {
323   const PERL_SI *si;
324   I32            requires = 0;
325
326   for (si = PL_curstackinfo; si; si = si->si_prev) {
327    I32 cxix;
328
329    for (cxix = si->si_cxix; cxix >= 0; --cxix) {
330     const PERL_CONTEXT *cx = si->si_cxstack + cxix;
331
332     if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_REQUIRE
333                                && ++requires > h->requires)
334      return NULL;
335    }
336   }
337  }
338 #endif
339
340  return h->code;
341 }
342
343 #else
344
345 STATIC SV *indirect_tag(pTHX_ SV *value) {
346 #define indirect_tag(V) indirect_tag(aTHX_ (V))
347  UV tag = 0;
348
349  if (SvOK(value) && SvROK(value)) {
350   value = SvRV(value);
351   SvREFCNT_inc(value);
352   tag = PTR2UV(value);
353  }
354
355  return newSVuv(tag);
356 }
357
358 #define indirect_detag(H) (((H) && SvOK(H)) ? INT2PTR(SV *, SvUVX(H)) : NULL)
359
360 #endif /* I_THREADSAFE || I_WORKAROUND_REQUIRE_PROPAGATION */
361
362 STATIC U32 indirect_hash = 0;
363
364 STATIC SV *indirect_hint(pTHX) {
365 #define indirect_hint() indirect_hint(aTHX)
366  SV *hint;
367
368  if (IN_PERL_RUNTIME)
369   return NULL;
370
371 #if I_HAS_PERL(5, 9, 5)
372  hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
373                                        NULL,
374                                        __PACKAGE__, __PACKAGE_LEN__,
375                                        0,
376                                        indirect_hash);
377 #else
378  {
379   SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__,
380                                                                  indirect_hash);
381   if (!val)
382    return 0;
383   hint = *val;
384  }
385 #endif
386  return indirect_detag(hint);
387 }
388
389 /* ... op -> source position ............................................... */
390
391 STATIC void indirect_map_store(pTHX_ const OP *o, const char *src, SV *sv, line_t line) {
392 #define indirect_map_store(O, S, N, L) indirect_map_store(aTHX_ (O), (S), (N), (L))
393  indirect_op_info_t *oi;
394  const char *s;
395  STRLEN len;
396  dMY_CXT;
397
398  /* When lex_inwhat is set, we're in a quotelike environment (qq, qr, but not q)
399   * In this case the linestr has temporarly changed, but the old buffer should
400   * still be alive somewhere. */
401
402  if (!PL_lex_inwhat) {
403   const char *pl_linestr = SvPVX_const(PL_linestr);
404   if (MY_CXT.linestr != pl_linestr) {
405    ptable_clear(MY_CXT.map);
406    MY_CXT.linestr = pl_linestr;
407   }
408  }
409
410  if (!(oi = ptable_fetch(MY_CXT.map, o))) {
411   Newx(oi, 1, indirect_op_info_t);
412   ptable_store(MY_CXT.map, o, oi);
413   oi->buf  = NULL;
414   oi->size = 0;
415  }
416
417  if (sv) {
418   s = SvPV_const(sv, len);
419  } else {
420   s   = "{";
421   len = 1;
422  }
423
424  if (len > oi->size) {
425   Safefree(oi->buf);
426   Newx(oi->buf, len, char);
427   oi->size = len;
428  }
429  Copy(s, oi->buf, len, char);
430
431  oi->len  = len;
432  oi->pos  = src;
433  oi->line = line;
434 }
435
436 STATIC const indirect_op_info_t *indirect_map_fetch(pTHX_ const OP *o) {
437 #define indirect_map_fetch(O) indirect_map_fetch(aTHX_ (O))
438  const indirect_op_info_t *val;
439  dMY_CXT;
440
441  if (MY_CXT.linestr != SvPVX_const(PL_linestr))
442   return NULL;
443
444  return ptable_fetch(MY_CXT.map, o);
445 }
446
447 STATIC void indirect_map_delete(pTHX_ const OP *o) {
448 #define indirect_map_delete(O) indirect_map_delete(aTHX_ (O))
449  dMY_CXT;
450
451  ptable_store(MY_CXT.map, o, NULL);
452 }
453
454 /* --- Check functions ----------------------------------------------------- */
455
456 STATIC const char *indirect_find(pTHX_ SV *sv, const char *s) {
457 #define indirect_find(N, S) indirect_find(aTHX_ (N), (S))
458  STRLEN len;
459  const char *p = NULL, *r = SvPV_const(sv, len);
460
461  if (len >= 1 && *r == '$') {
462   ++r;
463   --len;
464   s = strchr(s, '$');
465   if (!s)
466    return NULL;
467  }
468
469  p = strstr(s, r);
470  while (p) {
471   p += len;
472   if (!isALNUM(*p))
473    break;
474   p = strstr(p + 1, r);
475  }
476
477  return p;
478 }
479
480 /* ... ck_const ............................................................ */
481
482 STATIC OP *(*indirect_old_ck_const)(pTHX_ OP *) = 0;
483
484 STATIC OP *indirect_ck_const(pTHX_ OP *o) {
485  o = CALL_FPTR(indirect_old_ck_const)(aTHX_ o);
486
487  if (indirect_hint()) {
488   SV *sv = cSVOPo_sv;
489   if (SvPOK(sv) && (SvTYPE(sv) >= SVt_PV)) {
490    const char *s = indirect_find(sv, PL_oldbufptr);
491    indirect_map_store(o, s, sv, CopLINE(&PL_compiling));
492    return o;
493   }
494  }
495
496  indirect_map_delete(o);
497  return o;
498 }
499
500 /* ... ck_rv2sv ............................................................ */
501
502 STATIC OP *(*indirect_old_ck_rv2sv)(pTHX_ OP *) = 0;
503
504 STATIC OP *indirect_ck_rv2sv(pTHX_ OP *o) {
505  if (indirect_hint()) {
506   OP *op = cUNOPo->op_first;
507   SV *sv;
508   const char *name = NULL, *s;
509   STRLEN len;
510   OPCODE type = (OPCODE) op->op_type;
511
512   switch (type) {
513    case OP_GV:
514    case OP_GVSV: {
515     GV *gv = cGVOPx_gv(op);
516     name = GvNAME(gv);
517     len  = GvNAMELEN(gv);
518     break;
519    }
520    default:
521     if ((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP) {
522      SV *nsv = cSVOPx_sv(op);
523      if (SvPOK(nsv) && (SvTYPE(nsv) >= SVt_PV))
524       name = SvPV_const(nsv, len);
525     }
526   }
527   if (!name)
528    goto done;
529
530   sv = sv_2mortal(newSVpvn("$", 1));
531   sv_catpvn_nomg(sv, name, len);
532   s = indirect_find(sv, PL_oldbufptr);
533   if (!s) { /* If it failed, retry without the current stash */
534    const char *stash = HvNAME_get(PL_curstash);
535    STRLEN stashlen = HvNAMELEN_get(PL_curstash);
536
537    if ((len < stashlen + 2) || strnNE(name, stash, stashlen)
538        || name[stashlen] != ':' || name[stashlen+1] != ':') {
539     /* Failed again ? Try to remove main */
540     stash = "main";
541     stashlen = 4;
542     if ((len < stashlen + 2) || strnNE(name, stash, stashlen)
543         || name[stashlen] != ':' || name[stashlen+1] != ':')
544      goto done;
545    }
546
547    sv_setpvn(sv, "$", 1);
548    stashlen += 2;
549    sv_catpvn_nomg(sv, name + stashlen, len - stashlen);
550    s = indirect_find(sv, PL_oldbufptr);
551    if (!s)
552     goto done;
553   }
554
555   o = CALL_FPTR(indirect_old_ck_rv2sv)(aTHX_ o);
556   indirect_map_store(o, s, sv, CopLINE(&PL_compiling));
557   return o;
558  }
559
560 done:
561  o = CALL_FPTR(indirect_old_ck_rv2sv)(aTHX_ o);
562
563  indirect_map_delete(o);
564  return o;
565 }
566
567 /* ... ck_padany ........................................................... */
568
569 STATIC OP *(*indirect_old_ck_padany)(pTHX_ OP *) = 0;
570
571 STATIC OP *indirect_ck_padany(pTHX_ OP *o) {
572  o = CALL_FPTR(indirect_old_ck_padany)(aTHX_ o);
573
574  if (indirect_hint()) {
575   SV *sv;
576   const char *s = PL_oldbufptr, *t = PL_bufptr - 1;
577
578   while (s < t && isSPACE(*s)) ++s;
579   if (*s == '$' && ++s <= t) {
580    while (s < t && isSPACE(*s)) ++s;
581    while (s < t && isSPACE(*t)) --t;
582    sv = sv_2mortal(newSVpvn("$", 1));
583    sv_catpvn_nomg(sv, s, t - s + 1);
584    indirect_map_store(o, s, sv, CopLINE(&PL_compiling));
585    return o;
586   }
587  }
588
589  indirect_map_delete(o);
590  return o;
591 }
592
593 /* ... ck_scope ............................................................ */
594
595 STATIC OP *(*indirect_old_ck_scope)  (pTHX_ OP *) = 0;
596 STATIC OP *(*indirect_old_ck_lineseq)(pTHX_ OP *) = 0;
597
598 STATIC OP *indirect_ck_scope(pTHX_ OP *o) {
599  OP *(*old_ck)(pTHX_ OP *) = 0;
600
601  switch (o->op_type) {
602   case OP_SCOPE:   old_ck = indirect_old_ck_scope;   break;
603   case OP_LINESEQ: old_ck = indirect_old_ck_lineseq; break;
604  }
605  o = CALL_FPTR(old_ck)(aTHX_ o);
606
607  if (indirect_hint()) {
608   indirect_map_store(o, PL_oldbufptr, NULL, CopLINE(&PL_compiling));
609   return o;
610  }
611
612  indirect_map_delete(o);
613  return o;
614 }
615
616 /* We don't need to clean the map entries for leave ops because they can only
617  * be created by mutating from a lineseq. */
618
619 /* ... ck_method ........................................................... */
620
621 STATIC OP *(*indirect_old_ck_method)(pTHX_ OP *) = 0;
622
623 STATIC OP *indirect_ck_method(pTHX_ OP *o) {
624  if (indirect_hint()) {
625   OP *op = cUNOPo->op_first;
626   const indirect_op_info_t *oi = indirect_map_fetch(op);
627   const char *s = NULL;
628   line_t line;
629   SV *sv;
630
631   if (oi && (s = oi->pos)) {
632    sv   = sv_2mortal(newSVpvn(oi->buf, oi->len));
633    line = oi->line; /* Keep the old line so that we really point to the first */
634   } else {
635    sv = cSVOPx_sv(op);
636    if (!SvPOK(sv) || (SvTYPE(sv) < SVt_PV))
637     goto done;
638    sv   = sv_mortalcopy(sv);
639    s    = indirect_find(sv, PL_oldbufptr);
640    line = CopLINE(&PL_compiling);
641   }
642
643   o = CALL_FPTR(indirect_old_ck_method)(aTHX_ o);
644   /* o may now be a method_named */
645
646   indirect_map_store(o, s, sv, line);
647   return o;
648  }
649
650 done:
651  o = CALL_FPTR(indirect_old_ck_method)(aTHX_ o);
652
653  indirect_map_delete(o);
654  return o;
655 }
656
657 /* ... ck_entersub ......................................................... */
658
659 STATIC int indirect_is_indirect(const indirect_op_info_t *moi, const indirect_op_info_t *ooi) {
660  if (moi->pos > ooi->pos)
661   return 0;
662
663  if (moi->pos == ooi->pos)
664   return moi->len == ooi->len && !memcmp(moi->buf, ooi->buf, moi->len);
665
666  return 1;
667 }
668
669 STATIC OP *(*indirect_old_ck_entersub)(pTHX_ OP *) = 0;
670
671 STATIC OP *indirect_ck_entersub(pTHX_ OP *o) {
672  SV *code = indirect_hint();
673
674  o = CALL_FPTR(indirect_old_ck_entersub)(aTHX_ o);
675
676  if (code) {
677   const indirect_op_info_t *moi, *ooi;
678   OP     *mop, *oop;
679   LISTOP *lop;
680
681   oop = o;
682   do {
683    lop = (LISTOP *) oop;
684    if (!(lop->op_flags & OPf_KIDS))
685     goto done;
686    oop = lop->op_first;
687   } while (oop->op_type != OP_PUSHMARK);
688   oop = oop->op_sibling;
689   mop = lop->op_last;
690
691   if (!oop)
692    goto done;
693
694   switch (oop->op_type) {
695    case OP_CONST:
696    case OP_RV2SV:
697    case OP_PADSV:
698    case OP_SCOPE:
699    case OP_LEAVE:
700     break;
701    default:
702     goto done;
703   }
704
705   if (mop->op_type == OP_METHOD)
706    mop = cUNOPx(mop)->op_first;
707   else if (mop->op_type != OP_METHOD_NAMED)
708    goto done;
709
710   moi = indirect_map_fetch(mop);
711   if (!(moi && moi->pos))
712    goto done;
713
714   ooi = indirect_map_fetch(oop);
715   if (!(ooi && ooi->pos))
716    goto done;
717
718   if (indirect_is_indirect(moi, ooi)) {
719    SV *file;
720    dSP;
721
722    ENTER;
723    SAVETMPS;
724
725 #ifdef USE_ITHREADS
726    file = sv_2mortal(newSVpv(CopFILE(&PL_compiling), 0));
727 #else
728    file = sv_mortalcopy(CopFILESV(&PL_compiling));
729 #endif
730
731    PUSHMARK(SP);
732    EXTEND(SP, 4);
733    mPUSHp(ooi->buf, ooi->len);
734    mPUSHp(moi->buf, moi->len);
735    PUSHs(file);
736    mPUSHu(moi->line);
737    PUTBACK;
738
739    call_sv(code, G_VOID);
740
741    PUTBACK;
742
743    FREETMPS;
744    LEAVE;
745   }
746  }
747
748 done:
749  return o;
750 }
751
752 STATIC U32 indirect_initialized = 0;
753
754 /* --- XS ------------------------------------------------------------------ */
755
756 MODULE = indirect      PACKAGE = indirect
757
758 PROTOTYPES: ENABLE
759
760 BOOT:
761 {
762  if (!indirect_initialized++) {
763   HV *stash;
764
765   MY_CXT_INIT;
766   MY_CXT.map     = ptable_new();
767   MY_CXT.linestr = NULL;
768 #if I_THREADSAFE || I_WORKAROUND_REQUIRE_PROPAGATION
769   MY_CXT.tbl     = ptable_new();
770 #endif
771 #if I_THREADSAFE
772   MY_CXT.owner   = aTHX;
773 #endif
774
775   PERL_HASH(indirect_hash, __PACKAGE__, __PACKAGE_LEN__);
776
777   indirect_old_ck_const    = PL_check[OP_CONST];
778   PL_check[OP_CONST]       = MEMBER_TO_FPTR(indirect_ck_const);
779   indirect_old_ck_rv2sv    = PL_check[OP_RV2SV];
780   PL_check[OP_RV2SV]       = MEMBER_TO_FPTR(indirect_ck_rv2sv);
781   indirect_old_ck_padany   = PL_check[OP_PADANY];
782   PL_check[OP_PADANY]      = MEMBER_TO_FPTR(indirect_ck_padany);
783   indirect_old_ck_scope    = PL_check[OP_SCOPE];
784   PL_check[OP_SCOPE]       = MEMBER_TO_FPTR(indirect_ck_scope);
785   indirect_old_ck_lineseq  = PL_check[OP_LINESEQ];
786   PL_check[OP_LINESEQ]     = MEMBER_TO_FPTR(indirect_ck_scope);
787
788   indirect_old_ck_method   = PL_check[OP_METHOD];
789   PL_check[OP_METHOD]      = MEMBER_TO_FPTR(indirect_ck_method);
790   indirect_old_ck_entersub = PL_check[OP_ENTERSUB];
791   PL_check[OP_ENTERSUB]    = MEMBER_TO_FPTR(indirect_ck_entersub);
792
793   stash = gv_stashpvn(__PACKAGE__, __PACKAGE_LEN__, 1);
794   newCONSTSUB(stash, "I_THREADSAFE", newSVuv(I_THREADSAFE));
795  }
796 }
797
798 #if I_THREADSAFE
799
800 void
801 CLONE(...)
802 PROTOTYPE: DISABLE
803 PREINIT:
804  ptable *t;
805  int    *level;
806 CODE:
807  {
808   my_cxt_t ud;
809   dMY_CXT;
810   ud.tbl   = t = ptable_new();
811   ud.owner = MY_CXT.owner;
812   ptable_walk(MY_CXT.tbl, indirect_ptable_clone, &ud);
813  }
814  {
815   MY_CXT_CLONE;
816   MY_CXT.map     = ptable_new();
817   MY_CXT.linestr = NULL;
818   MY_CXT.tbl     = t;
819   MY_CXT.owner   = aTHX;
820  }
821  {
822   level = PerlMemShared_malloc(sizeof *level);
823   *level = 1;
824   LEAVE;
825   SAVEDESTRUCTOR_X(indirect_thread_cleanup, level);
826   ENTER;
827  }
828
829 #endif
830
831 SV *
832 _tag(SV *value)
833 PROTOTYPE: $
834 CODE:
835  RETVAL = indirect_tag(value);
836 OUTPUT:
837  RETVAL