1 /* This file is part of the indirect Perl module.
2 * See http://search.cpan.org/dist/indirect/ */
4 #define PERL_NO_GET_CONTEXT
9 #define __PACKAGE__ "indirect"
10 #define __PACKAGE_LEN__ (sizeof(__PACKAGE__)-1)
12 /* --- Compatibility wrappers ---------------------------------------------- */
23 # define Newx(v, n, c) New(0, v, n, c)
27 # define SvPV_const SvPV
30 #ifndef SvPV_nolen_const
31 # define SvPV_nolen_const SvPV_nolen
35 # define SvPVX_const SvPVX
38 #ifndef SvREFCNT_inc_simple_void_NN
39 # ifdef SvREFCNT_inc_simple_NN
40 # define SvREFCNT_inc_simple_void_NN SvREFCNT_inc_simple_NN
42 # define SvREFCNT_inc_simple_void_NN SvREFCNT_inc
46 #ifndef sv_catpvn_nomg
47 # define sv_catpvn_nomg sv_catpvn
51 # define mPUSHp(P, L) PUSHs(sv_2mortal(newSVpvn((P), (L))))
55 # define mPUSHu(U) PUSHs(sv_2mortal(newSVuv(U)))
59 # define HvNAME_get(H) HvNAME(H)
63 # define HvNAMELEN_get(H) strlen(HvNAME_get(H))
66 #define I_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
68 #if I_HAS_PERL(5, 10, 0) || defined(PL_parser)
70 # define PL_linestr PL_parser->linestr
73 # define PL_bufptr PL_parser->bufptr
76 # define PL_oldbufptr PL_parser->oldbufptr
80 # define PL_linestr PL_Ilinestr
83 # define PL_bufptr PL_Ibufptr
86 # define PL_oldbufptr PL_Ioldbufptr
90 #ifndef I_WORKAROUND_REQUIRE_PROPAGATION
91 # define I_WORKAROUND_REQUIRE_PROPAGATION !I_HAS_PERL(5, 10, 1)
94 /* ... Thread safety and multiplicity ...................................... */
96 /* Safe unless stated otherwise in Makefile.PL */
101 #ifndef I_MULTIPLICITY
102 # if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT)
103 # define I_MULTIPLICITY 1
105 # define I_MULTIPLICITY 0
108 #if I_MULTIPLICITY && !defined(tTHX)
109 # define tTHX PerlInterpreter*
112 #if I_MULTIPLICITY && defined(USE_ITHREADS) && defined(dMY_CXT) && defined(MY_CXT) && defined(START_MY_CXT) && defined(MY_CXT_INIT) && (defined(MY_CXT_CLONE) || defined(dMY_CXT_SV))
113 # define I_THREADSAFE 1
114 # ifndef MY_CXT_CLONE
115 # define MY_CXT_CLONE \
117 my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1)); \
118 Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t); \
119 sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
122 # define I_THREADSAFE 0
124 # define dMY_CXT dNOOP
126 # define MY_CXT indirect_globaldata
128 # define START_MY_CXT STATIC my_cxt_t MY_CXT;
130 # define MY_CXT_INIT NOOP
132 # define MY_CXT_CLONE NOOP
135 /* --- Helpers ------------------------------------------------------------- */
137 /* ... Thread-safe hints ................................................... */
139 #if I_WORKAROUND_REQUIRE_PROPAGATION
146 #define I_HINT_STRUCT 1
148 #define I_HINT_CODE(H) ((H)->code)
150 #define I_HINT_FREE(H) { \
151 indirect_hint_t *h = (H); \
152 SvREFCNT_dec(h->code); \
153 PerlMemShared_free(h); \
156 #else /* I_WORKAROUND_REQUIRE_PROPAGATION */
158 typedef SV indirect_hint_t;
160 #define I_HINT_STRUCT 0
162 #define I_HINT_CODE(H) (H)
164 #define I_HINT_FREE(H) SvREFCNT_dec(H);
166 #endif /* !I_WORKAROUND_REQUIRE_PROPAGATION */
170 #define PTABLE_NAME ptable_hints
171 #define PTABLE_VAL_FREE(V) I_HINT_FREE(V)
180 #define ptable_hints_store(T, K, V) ptable_hints_store(aTHX_ (T), (K), (V))
181 #define ptable_hints_free(T) ptable_hints_free(aTHX_ (T))
183 #endif /* I_THREADSAFE */
185 /* Define the op->str ptable here because we need to be able to clean it during
194 } indirect_op_info_t;
196 #define PTABLE_NAME ptable
197 #define PTABLE_VAL_FREE(V) if (V) { Safefree(((indirect_op_info_t *) (V))->buf); Safefree(V); }
206 #define ptable_store(T, K, V) ptable_store(aTHX_ (T), (K), (V))
207 #define ptable_delete(T, K) ptable_delete(aTHX_ (T), (K))
208 #define ptable_clear(T) ptable_clear(aTHX_ (T))
209 #define ptable_free(T) ptable_free(aTHX_ (T))
211 #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
215 ptable *tbl; /* It really is a ptable_hints */
226 STATIC SV *indirect_clone(pTHX_ SV *sv, tTHX owner) {
227 #define indirect_clone(S, O) indirect_clone(aTHX_ (S), (O))
235 if (SvTYPE(sv) == SVt_PVHV && HvNAME_get(sv))
238 param.stashes = stashes;
240 param.proto_perl = owner;
242 dupsv = sv_dup(sv, ¶m);
246 SvREFCNT_dec(stashes);
249 return SvREFCNT_inc(dupsv);
252 STATIC void indirect_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) {
254 indirect_hint_t *h1 = ent->val;
257 if (ud->owner == aTHX)
262 h2 = PerlMemShared_malloc(sizeof *h2);
263 h2->code = indirect_clone(h1->code, ud->owner);
264 #if I_WORKAROUND_REQUIRE_PROPAGATION
265 h2->require_tag = PTR2IV(indirect_clone(INT2PTR(SV *, h1->require_tag),
269 #else /* I_HINT_STRUCT */
271 h2 = indirect_clone(h1, ud->owner);
273 #endif /* !I_HINT_STRUCT */
275 ptable_hints_store(ud->tbl, ent->key, h2);
280 STATIC void indirect_thread_cleanup(pTHX_ void *ud) {
283 SvREFCNT_dec(MY_CXT.global_code);
284 ptable_free(MY_CXT.map);
285 ptable_hints_free(MY_CXT.tbl);
288 #endif /* I_THREADSAFE */
290 #if I_WORKAROUND_REQUIRE_PROPAGATION
291 STATIC IV indirect_require_tag(pTHX) {
292 #define indirect_require_tag() indirect_require_tag(aTHX)
293 const CV *cv, *outside;
298 /* If for some reason the pragma is operational at run-time, try to discover
299 * the current cv in use. */
302 for (si = PL_curstackinfo; si; si = si->si_prev) {
305 for (cxix = si->si_cxix; cxix >= 0; --cxix) {
306 const PERL_CONTEXT *cx = si->si_cxstack + cxix;
308 switch (CxTYPE(cx)) {
311 /* The propagation workaround is only needed up to 5.10.0 and at that
312 * time format and sub contexts were still identical. And even later the
313 * cv members offsets should have been kept the same. */
315 goto get_enclosing_cv;
317 cv = cx->blk_eval.cv;
318 goto get_enclosing_cv;
329 for (outside = CvOUTSIDE(cv); outside; outside = CvOUTSIDE(cv))
334 #endif /* I_WORKAROUND_REQUIRE_PROPAGATION */
336 STATIC SV *indirect_tag(pTHX_ SV *value) {
337 #define indirect_tag(V) indirect_tag(aTHX_ (V))
343 if (SvTYPE(value) >= SVt_PVCV) {
345 SvREFCNT_inc_simple_void_NN(code);
350 h = PerlMemShared_malloc(sizeof *h);
352 # if I_WORKAROUND_REQUIRE_PROPAGATION
353 h->require_tag = indirect_require_tag();
354 # endif /* I_WORKAROUND_REQUIRE_PROPAGATION */
355 #else /* I_HINT_STRUCT */
357 #endif /* !I_HINT_STRUCT */
362 /* We only need for the key to be an unique tag for looking up the value later
363 * Allocated memory provides convenient unique identifiers, so that's why we
364 * use the hint as the key itself. */
365 ptable_hints_store(MY_CXT.tbl, h, h);
367 #endif /* I_THREADSAFE */
369 return newSViv(PTR2IV(h));
372 STATIC SV *indirect_detag(pTHX_ const SV *hint) {
373 #define indirect_detag(H) indirect_detag(aTHX_ (H))
375 #if I_THREADSAFE || I_WORKAROUND_REQUIRE_PROPAGATION
379 h = INT2PTR(indirect_hint_t *, SvIVX(hint));
381 h = ptable_fetch(MY_CXT.tbl, h);
382 #endif /* I_THREADSAFE */
384 #if I_WORKAROUND_REQUIRE_PROPAGATION
385 if (indirect_require_tag() != h->require_tag)
386 return MY_CXT.global_code;
387 #endif /* I_WORKAROUND_REQUIRE_PROPAGATION */
389 return I_HINT_CODE(h);
392 STATIC U32 indirect_hash = 0;
394 STATIC SV *indirect_hint(pTHX) {
395 #define indirect_hint() indirect_hint(aTHX)
401 #if I_HAS_PERL(5, 10, 0) || defined(PL_parser)
406 #ifdef cop_hints_fetch_pvn
407 hint = cop_hints_fetch_pvn(PL_curcop, __PACKAGE__, __PACKAGE_LEN__,
409 #elif I_HAS_PERL(5, 9, 5)
410 hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
412 __PACKAGE__, __PACKAGE_LEN__,
417 SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__, 0);
423 if (hint && SvIOK(hint))
424 return indirect_detag(hint);
427 return MY_CXT.global_code;
431 /* ... op -> source position ............................................... */
433 STATIC void indirect_map_store(pTHX_ const OP *o, STRLEN pos, SV *sv, line_t line) {
434 #define indirect_map_store(O, P, N, L) indirect_map_store(aTHX_ (O), (P), (N), (L))
435 indirect_op_info_t *oi;
440 if (!(oi = ptable_fetch(MY_CXT.map, o))) {
441 Newx(oi, 1, indirect_op_info_t);
442 ptable_store(MY_CXT.map, o, oi);
448 s = SvPV_const(sv, len);
454 if (len > oi->size) {
456 Newx(oi->buf, len, char);
459 Copy(s, oi->buf, len, char);
466 STATIC const indirect_op_info_t *indirect_map_fetch(pTHX_ const OP *o) {
467 #define indirect_map_fetch(O) indirect_map_fetch(aTHX_ (O))
470 return ptable_fetch(MY_CXT.map, o);
473 STATIC void indirect_map_delete(pTHX_ const OP *o) {
474 #define indirect_map_delete(O) indirect_map_delete(aTHX_ (O))
477 ptable_delete(MY_CXT.map, o);
480 /* --- Check functions ----------------------------------------------------- */
482 STATIC int indirect_find(pTHX_ SV *sv, const char *s, STRLEN *pos) {
483 #define indirect_find(N, S, P) indirect_find(aTHX_ (N), (S), (P))
485 const char *p, *r = SvPV_const(sv, len);
487 if (len >= 1 && *r == '$') {
500 if (!isALNUM(p[len]))
502 /* p points to a word that has r as prefix, skip the rest of the word */
508 *pos = p - SvPVX_const(PL_linestr);
513 /* ... ck_const ............................................................ */
515 STATIC OP *(*indirect_old_ck_const)(pTHX_ OP *) = 0;
517 STATIC OP *indirect_ck_const(pTHX_ OP *o) {
518 o = indirect_old_ck_const(aTHX_ o);
520 if (indirect_hint()) {
523 if (SvPOK(sv) && (SvTYPE(sv) >= SVt_PV)) {
526 if (indirect_find(sv, PL_oldbufptr, &pos)) {
527 indirect_map_store(o, pos, sv, CopLINE(&PL_compiling));
533 indirect_map_delete(o);
537 /* ... ck_rv2sv ............................................................ */
539 STATIC OP *(*indirect_old_ck_rv2sv)(pTHX_ OP *) = 0;
541 STATIC OP *indirect_ck_rv2sv(pTHX_ OP *o) {
542 if (indirect_hint()) {
543 OP *op = cUNOPo->op_first;
545 const char *name = NULL;
547 OPCODE type = (OPCODE) op->op_type;
552 GV *gv = cGVOPx_gv(op);
558 if ((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP) {
559 SV *nsv = cSVOPx_sv(op);
560 if (SvPOK(nsv) && (SvTYPE(nsv) >= SVt_PV))
561 name = SvPV_const(nsv, len);
567 sv = sv_2mortal(newSVpvn("$", 1));
568 sv_catpvn_nomg(sv, name, len);
569 if (!indirect_find(sv, PL_oldbufptr, &pos)) {
570 /* If it failed, retry without the current stash */
571 const char *stash = HvNAME_get(PL_curstash);
572 STRLEN stashlen = HvNAMELEN_get(PL_curstash);
574 if ((len < stashlen + 2) || strnNE(name, stash, stashlen)
575 || name[stashlen] != ':' || name[stashlen+1] != ':') {
576 /* Failed again ? Try to remove main */
579 if ((len < stashlen + 2) || strnNE(name, stash, stashlen)
580 || name[stashlen] != ':' || name[stashlen+1] != ':')
584 sv_setpvn(sv, "$", 1);
586 sv_catpvn_nomg(sv, name + stashlen, len - stashlen);
587 if (!indirect_find(sv, PL_oldbufptr, &pos))
591 o = indirect_old_ck_rv2sv(aTHX_ o);
593 indirect_map_store(o, pos, sv, CopLINE(&PL_compiling));
598 o = indirect_old_ck_rv2sv(aTHX_ o);
600 indirect_map_delete(o);
604 /* ... ck_padany ........................................................... */
606 STATIC OP *(*indirect_old_ck_padany)(pTHX_ OP *) = 0;
608 STATIC OP *indirect_ck_padany(pTHX_ OP *o) {
609 o = indirect_old_ck_padany(aTHX_ o);
611 if (indirect_hint()) {
613 const char *s = PL_oldbufptr, *t = PL_bufptr - 1;
615 while (s < t && isSPACE(*s)) ++s;
616 if (*s == '$' && ++s <= t) {
617 while (s < t && isSPACE(*s)) ++s;
618 while (s < t && isSPACE(*t)) --t;
619 sv = sv_2mortal(newSVpvn("$", 1));
620 sv_catpvn_nomg(sv, s, t - s + 1);
621 indirect_map_store(o, s - SvPVX_const(PL_linestr),
622 sv, CopLINE(&PL_compiling));
627 indirect_map_delete(o);
631 /* ... ck_scope ............................................................ */
633 STATIC OP *(*indirect_old_ck_scope) (pTHX_ OP *) = 0;
634 STATIC OP *(*indirect_old_ck_lineseq)(pTHX_ OP *) = 0;
636 STATIC OP *indirect_ck_scope(pTHX_ OP *o) {
637 OP *(*old_ck)(pTHX_ OP *) = 0;
639 switch (o->op_type) {
640 case OP_SCOPE: old_ck = indirect_old_ck_scope; break;
641 case OP_LINESEQ: old_ck = indirect_old_ck_lineseq; break;
645 if (indirect_hint()) {
646 indirect_map_store(o, PL_oldbufptr - SvPVX_const(PL_linestr),
647 NULL, CopLINE(&PL_compiling));
651 indirect_map_delete(o);
655 /* We don't need to clean the map entries for leave ops because they can only
656 * be created by mutating from a lineseq. */
658 /* ... ck_method ........................................................... */
660 STATIC OP *(*indirect_old_ck_method)(pTHX_ OP *) = 0;
662 STATIC OP *indirect_ck_method(pTHX_ OP *o) {
663 if (indirect_hint()) {
664 OP *op = cUNOPo->op_first;
666 /* Indirect method call is only possible when the method is a bareword, so
667 * don't trip up on $obj->$meth. */
668 if (op && op->op_type == OP_CONST) {
669 const indirect_op_info_t *oi = indirect_map_fetch(op);
677 sv = sv_2mortal(newSVpvn(oi->buf, oi->len));
679 /* Keep the old line so that we really point to the first line of the
683 o = indirect_old_ck_method(aTHX_ o);
684 /* o may now be a method_named */
686 indirect_map_store(o, pos, sv, line);
692 o = indirect_old_ck_method(aTHX_ o);
694 indirect_map_delete(o);
698 /* ... ck_method_named ..................................................... */
700 /* "use foo/no foo" compiles its call to import/unimport directly to a
701 * method_named op. */
703 STATIC OP *(*indirect_old_ck_method_named)(pTHX_ OP *) = 0;
705 STATIC OP *indirect_ck_method_named(pTHX_ OP *o) {
706 if (indirect_hint()) {
712 if (!SvPOK(sv) || (SvTYPE(sv) < SVt_PV))
714 sv = sv_mortalcopy(sv);
716 if (!indirect_find(sv, PL_oldbufptr, &pos))
718 line = CopLINE(&PL_compiling);
720 o = indirect_old_ck_method_named(aTHX_ o);
722 indirect_map_store(o, pos, sv, line);
727 o = indirect_old_ck_method_named(aTHX_ o);
729 indirect_map_delete(o);
733 /* ... ck_entersub ......................................................... */
735 STATIC OP *(*indirect_old_ck_entersub)(pTHX_ OP *) = 0;
737 STATIC OP *indirect_ck_entersub(pTHX_ OP *o) {
738 SV *code = indirect_hint();
740 o = indirect_old_ck_entersub(aTHX_ o);
743 const indirect_op_info_t *moi, *ooi;
749 lop = (LISTOP *) oop;
750 if (!(lop->op_flags & OPf_KIDS))
753 } while (oop->op_type != OP_PUSHMARK);
754 oop = oop->op_sibling;
760 switch (oop->op_type) {
771 if (mop->op_type == OP_METHOD)
772 mop = cUNOPx(mop)->op_first;
773 else if (mop->op_type != OP_METHOD_NAMED)
776 moi = indirect_map_fetch(mop);
780 ooi = indirect_map_fetch(oop);
784 /* When positions are identical, the method and the object must have the
785 * same name. But it also means that it is an indirect call, as "foo->foo"
786 * results in different positions. */
787 if (moi->pos <= ooi->pos) {
795 file = sv_2mortal(newSVpv(CopFILE(&PL_compiling), 0));
797 file = sv_mortalcopy(CopFILESV(&PL_compiling));
802 mPUSHp(ooi->buf, ooi->len);
803 mPUSHp(moi->buf, moi->len);
808 call_sv(code, G_VOID);
821 STATIC U32 indirect_initialized = 0;
823 STATIC void indirect_teardown(pTHX_ void *root) {
824 if (!indirect_initialized)
834 ptable_free(MY_CXT.map);
836 ptable_hints_free(MY_CXT.tbl);
840 PL_check[OP_CONST] = MEMBER_TO_FPTR(indirect_old_ck_const);
841 indirect_old_ck_const = 0;
842 PL_check[OP_RV2SV] = MEMBER_TO_FPTR(indirect_old_ck_rv2sv);
843 indirect_old_ck_rv2sv = 0;
844 PL_check[OP_PADANY] = MEMBER_TO_FPTR(indirect_old_ck_padany);
845 indirect_old_ck_padany = 0;
846 PL_check[OP_SCOPE] = MEMBER_TO_FPTR(indirect_old_ck_scope);
847 indirect_old_ck_scope = 0;
848 PL_check[OP_LINESEQ] = MEMBER_TO_FPTR(indirect_old_ck_lineseq);
849 indirect_old_ck_lineseq = 0;
851 PL_check[OP_METHOD] = MEMBER_TO_FPTR(indirect_old_ck_method);
852 indirect_old_ck_method = 0;
853 PL_check[OP_METHOD_NAMED] = MEMBER_TO_FPTR(indirect_old_ck_method_named);
854 indirect_old_ck_method_named = 0;
855 PL_check[OP_ENTERSUB] = MEMBER_TO_FPTR(indirect_old_ck_entersub);
856 indirect_old_ck_entersub = 0;
858 indirect_initialized = 0;
861 STATIC void indirect_setup(pTHX) {
862 #define indirect_setup() indirect_setup(aTHX)
863 if (indirect_initialized)
869 MY_CXT.tbl = ptable_new();
872 MY_CXT.map = ptable_new();
873 MY_CXT.global_code = NULL;
876 indirect_old_ck_const = PL_check[OP_CONST];
877 PL_check[OP_CONST] = MEMBER_TO_FPTR(indirect_ck_const);
878 indirect_old_ck_rv2sv = PL_check[OP_RV2SV];
879 PL_check[OP_RV2SV] = MEMBER_TO_FPTR(indirect_ck_rv2sv);
880 indirect_old_ck_padany = PL_check[OP_PADANY];
881 PL_check[OP_PADANY] = MEMBER_TO_FPTR(indirect_ck_padany);
882 indirect_old_ck_scope = PL_check[OP_SCOPE];
883 PL_check[OP_SCOPE] = MEMBER_TO_FPTR(indirect_ck_scope);
884 indirect_old_ck_lineseq = PL_check[OP_LINESEQ];
885 PL_check[OP_LINESEQ] = MEMBER_TO_FPTR(indirect_ck_scope);
887 indirect_old_ck_method = PL_check[OP_METHOD];
888 PL_check[OP_METHOD] = MEMBER_TO_FPTR(indirect_ck_method);
889 indirect_old_ck_method_named = PL_check[OP_METHOD_NAMED];
890 PL_check[OP_METHOD_NAMED] = MEMBER_TO_FPTR(indirect_ck_method_named);
891 indirect_old_ck_entersub = PL_check[OP_ENTERSUB];
892 PL_check[OP_ENTERSUB] = MEMBER_TO_FPTR(indirect_ck_entersub);
895 call_atexit(indirect_teardown, aTHX);
897 call_atexit(indirect_teardown, NULL);
900 indirect_initialized = 1;
903 STATIC U32 indirect_booted = 0;
905 /* --- XS ------------------------------------------------------------------ */
907 MODULE = indirect PACKAGE = indirect
913 if (!indirect_booted++) {
916 PERL_HASH(indirect_hash, __PACKAGE__, __PACKAGE_LEN__);
918 stash = gv_stashpvn(__PACKAGE__, __PACKAGE_LEN__, 1);
919 newCONSTSUB(stash, "I_THREADSAFE", newSVuv(I_THREADSAFE));
920 newCONSTSUB(stash, "I_FORKSAFE", newSVuv(I_FORKSAFE));
938 ud.tbl = t = ptable_new();
939 ud.owner = MY_CXT.owner;
940 ptable_walk(MY_CXT.tbl, indirect_ptable_clone, &ud);
941 global_code_dup = indirect_clone(MY_CXT.global_code, MY_CXT.owner);
945 MY_CXT.map = ptable_new();
948 MY_CXT.global_code = global_code_dup;
950 reap(3, indirect_thread_cleanup, NULL);
959 RETVAL = indirect_tag(value);
969 else if (SvROK(code))
973 SvREFCNT_dec(MY_CXT.global_code);
974 MY_CXT.global_code = SvREFCNT_inc(code);