File Coverage

File:indirect.xs
Coverage:96.9%

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