X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2Findirect.git;a=blobdiff_plain;f=indirect.xs;h=3bd5e6cef5addca2a46f23de0f07979c1152d5dc;hp=53cff20b16bddf792a5d0245cd10e7ab317fb807;hb=07fb4eb28539b53578b1421e348c12c921d180f1;hpb=d237f88f7fb8be8d6836157872d5bf2b9ba02beb diff --git a/indirect.xs b/indirect.xs index 53cff20..3bd5e6c 100644 --- a/indirect.xs +++ b/indirect.xs @@ -35,8 +35,12 @@ # define SvPVX_const SvPVX #endif -#ifndef SvREFCNT_inc_simple_NN -# define SvREFCNT_inc_simple_NN SvREFCNT_inc +#ifndef SvREFCNT_inc_simple_void_NN +# ifdef SvREFCNT_inc_simple_NN +# define SvREFCNT_inc_simple_void_NN SvREFCNT_inc_simple_NN +# else +# define SvREFCNT_inc_simple_void_NN SvREFCNT_inc +# endif #endif #ifndef sv_catpvn_nomg @@ -62,9 +66,6 @@ #define I_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S)))))) #if I_HAS_PERL(5, 10, 0) || defined(PL_parser) -# ifndef PL_lex_inwhat -# define PL_lex_inwhat PL_parser->lex_inwhat -# endif # ifndef PL_linestr # define PL_linestr PL_parser->linestr # endif @@ -74,10 +75,10 @@ # ifndef PL_oldbufptr # define PL_oldbufptr PL_parser->oldbufptr # endif -#else # ifndef PL_lex_inwhat -# define PL_lex_inwhat PL_Ilex_inwhat +# define PL_lex_inwhat PL_parser->lex_inwhat # endif +#else # ifndef PL_linestr # define PL_linestr PL_Ilinestr # endif @@ -87,6 +88,9 @@ # ifndef PL_oldbufptr # define PL_oldbufptr PL_Ioldbufptr # endif +# ifndef PL_lex_inwhat +# define PL_lex_inwhat PL_Ilex_inwhat +# endif #endif #ifndef I_WORKAROUND_REQUIRE_PROPAGATION @@ -95,6 +99,11 @@ /* ... Thread safety and multiplicity ...................................... */ +/* Safe unless stated otherwise in Makefile.PL */ +#ifndef I_FORKSAFE +# define I_FORKSAFE 1 +#endif + #ifndef I_MULTIPLICITY # if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT) # define I_MULTIPLICITY 1 @@ -129,6 +138,44 @@ # define MY_CXT_CLONE NOOP #endif +#if defined(OP_CHECK_MUTEX_LOCK) && defined(OP_CHECK_MUTEX_UNLOCK) +# define I_CHECK_MUTEX_LOCK OP_CHECK_MUTEX_LOCK +# define I_CHECK_MUTEX_UNLOCK OP_CHECK_MUTEX_UNLOCK +#else +# define I_CHECK_MUTEX_LOCK OP_REFCNT_LOCK +# define I_CHECK_MUTEX_UNLOCK OP_REFCNT_UNLOCK +#endif + +typedef OP *(*indirect_ck_t)(pTHX_ OP *); + +#ifdef wrap_op_checker + +# define indirect_ck_replace(T, NC, OCP) wrap_op_checker((T), (NC), (OCP)) + +#else + +STATIC void indirect_ck_replace(pTHX_ OPCODE type, indirect_ck_t new_ck, indirect_ck_t *old_ck_p) { +#define indirect_ck_replace(T, NC, OCP) indirect_ck_replace(aTHX_ (T), (NC), (OCP)) + I_CHECK_MUTEX_LOCK; + if (!*old_ck_p) { + *old_ck_p = PL_check[type]; + PL_check[type] = new_ck; + } + I_CHECK_MUTEX_UNLOCK; +} + +#endif + +STATIC void indirect_ck_restore(pTHX_ OPCODE type, indirect_ck_t *old_ck_p) { +#define indirect_ck_restore(T, OCP) indirect_ck_restore(aTHX_ (T), (OCP)) + I_CHECK_MUTEX_LOCK; + if (*old_ck_p) { + PL_check[type] = *old_ck_p; + *old_ck_p = 0; + } + I_CHECK_MUTEX_UNLOCK; +} + /* --- Helpers ------------------------------------------------------------- */ /* ... Thread-safe hints ................................................... */ @@ -136,8 +183,8 @@ #if I_WORKAROUND_REQUIRE_PROPAGATION typedef struct { - SV *code; - I32 requires; + SV *code; + IV require_tag; } indirect_hint_t; #define I_HINT_STRUCT 1 @@ -183,10 +230,11 @@ typedef SV indirect_hint_t; * thread cleanup. */ typedef struct { - const char *pos; - char *buf; - STRLEN len, size; - line_t line; + char *buf; + STRLEN pos; + STRLEN size; + STRLEN len; + line_t line; } indirect_op_info_t; #define PTABLE_NAME ptable @@ -200,6 +248,7 @@ typedef struct { #include "ptable.h" #define ptable_store(T, K, V) ptable_store(aTHX_ (T), (K), (V)) +#define ptable_delete(T, K) ptable_delete(aTHX_ (T), (K)) #define ptable_clear(T) ptable_clear(aTHX_ (T)) #define ptable_free(T) ptable_free(aTHX_ (T)) @@ -207,11 +256,11 @@ typedef struct { typedef struct { #if I_THREADSAFE - ptable *tbl; /* It really is a ptable_hints */ - tTHX owner; + ptable *tbl; /* It really is a ptable_hints */ + tTHX owner; #endif - ptable *map; - const char *linestr; + ptable *map; + SV *global_code; } my_cxt_t; START_MY_CXT @@ -224,6 +273,9 @@ STATIC SV *indirect_clone(pTHX_ SV *sv, tTHX owner) { AV *stashes = NULL; SV *dupsv; + if (!sv) + return NULL; + if (SvTYPE(sv) == SVt_PVHV && HvNAME_get(sv)) stashes = newAV(); @@ -251,65 +303,45 @@ STATIC void indirect_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) { #if I_HINT_STRUCT - h2 = PerlMemShared_malloc(sizeof *h2); - h2->code = indirect_clone(h1->code, ud->owner); - SvREFCNT_inc(h2->code); + h2 = PerlMemShared_malloc(sizeof *h2); + h2->code = indirect_clone(h1->code, ud->owner); #if I_WORKAROUND_REQUIRE_PROPAGATION - h2->requires = h1->requires; + h2->require_tag = PTR2IV(indirect_clone(INT2PTR(SV *, h1->require_tag), + ud->owner)); #endif #else /* I_HINT_STRUCT */ h2 = indirect_clone(h1, ud->owner); - SvREFCNT_inc(h2); #endif /* !I_HINT_STRUCT */ ptable_hints_store(ud->tbl, ent->key, h2); } -STATIC void indirect_thread_cleanup(pTHX_ void *); +#include "reap.h" STATIC void indirect_thread_cleanup(pTHX_ void *ud) { - int *level = ud; + dMY_CXT; - if (*level) { - *level = 0; - LEAVE; - SAVEDESTRUCTOR_X(indirect_thread_cleanup, level); - ENTER; - } else { - dMY_CXT; - PerlMemShared_free(level); - ptable_free(MY_CXT.map); - ptable_hints_free(MY_CXT.tbl); - } + SvREFCNT_dec(MY_CXT.global_code); + ptable_free(MY_CXT.map); + ptable_hints_free(MY_CXT.tbl); } #endif /* I_THREADSAFE */ -STATIC SV *indirect_tag(pTHX_ SV *value) { -#define indirect_tag(V) indirect_tag(aTHX_ (V)) - indirect_hint_t *h; - SV *code = NULL; - dMY_CXT; - - if (SvROK(value)) { - value = SvRV(value); - if (SvTYPE(value) >= SVt_PVCV) { - code = value; - SvREFCNT_inc_simple_NN(code); - } - } +#if I_WORKAROUND_REQUIRE_PROPAGATION +STATIC IV indirect_require_tag(pTHX) { +#define indirect_require_tag() indirect_require_tag(aTHX) + const CV *cv, *outside; -#if I_HINT_STRUCT - h = PerlMemShared_malloc(sizeof *h); - h->code = code; + cv = PL_compcv; -#if I_WORKAROUND_REQUIRE_PROPAGATION - { + if (!cv) { + /* If for some reason the pragma is operational at run-time, try to discover + * the current cv in use. */ const PERL_SI *si; - I32 requires = 0; for (si = PL_curstackinfo; si; si = si->si_prev) { I32 cxix; @@ -317,24 +349,65 @@ STATIC SV *indirect_tag(pTHX_ SV *value) { for (cxix = si->si_cxix; cxix >= 0; --cxix) { const PERL_CONTEXT *cx = si->si_cxstack + cxix; - if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_REQUIRE) - ++requires; + switch (CxTYPE(cx)) { + case CXt_SUB: + case CXt_FORMAT: + /* The propagation workaround is only needed up to 5.10.0 and at that + * time format and sub contexts were still identical. And even later the + * cv members offsets should have been kept the same. */ + cv = cx->blk_sub.cv; + goto get_enclosing_cv; + case CXt_EVAL: + cv = cx->blk_eval.cv; + goto get_enclosing_cv; + default: + break; + } } } - h->requires = requires; + cv = PL_main_cv; } + +get_enclosing_cv: + for (outside = CvOUTSIDE(cv); outside; outside = CvOUTSIDE(cv)) + cv = outside; + + return PTR2IV(cv); +} #endif /* I_WORKAROUND_REQUIRE_PROPAGATION */ +STATIC SV *indirect_tag(pTHX_ SV *value) { +#define indirect_tag(V) indirect_tag(aTHX_ (V)) + indirect_hint_t *h; + SV *code = NULL; + + if (SvROK(value)) { + value = SvRV(value); + if (SvTYPE(value) >= SVt_PVCV) { + code = value; + SvREFCNT_inc_simple_void_NN(code); + } + } + +#if I_HINT_STRUCT + h = PerlMemShared_malloc(sizeof *h); + h->code = code; +# if I_WORKAROUND_REQUIRE_PROPAGATION + h->require_tag = indirect_require_tag(); +# endif /* I_WORKAROUND_REQUIRE_PROPAGATION */ #else /* I_HINT_STRUCT */ h = code; #endif /* !I_HINT_STRUCT */ #if I_THREADSAFE - /* We only need for the key to be an unique tag for looking up the value later. - * Allocated memory provides convenient unique identifiers, so that's why we - * use the hint as the key itself. */ - ptable_hints_store(MY_CXT.tbl, h, h); + { + dMY_CXT; + /* We only need for the key to be an unique tag for looking up the value later + * Allocated memory provides convenient unique identifiers, so that's why we + * use the hint as the key itself. */ + ptable_hints_store(MY_CXT.tbl, h, h); + } #endif /* I_THREADSAFE */ return newSViv(PTR2IV(h)); @@ -343,10 +416,9 @@ STATIC SV *indirect_tag(pTHX_ SV *value) { STATIC SV *indirect_detag(pTHX_ const SV *hint) { #define indirect_detag(H) indirect_detag(aTHX_ (H)) indirect_hint_t *h; +#if I_THREADSAFE || I_WORKAROUND_REQUIRE_PROPAGATION dMY_CXT; - - if (!(hint && SvIOK(hint))) - return NULL; +#endif h = INT2PTR(indirect_hint_t *, SvIVX(hint)); #if I_THREADSAFE @@ -354,22 +426,8 @@ STATIC SV *indirect_detag(pTHX_ const SV *hint) { #endif /* I_THREADSAFE */ #if I_WORKAROUND_REQUIRE_PROPAGATION - { - const PERL_SI *si; - I32 requires = 0; - - for (si = PL_curstackinfo; si; si = si->si_prev) { - I32 cxix; - - for (cxix = si->si_cxix; cxix >= 0; --cxix) { - const PERL_CONTEXT *cx = si->si_cxstack + cxix; - - if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_REQUIRE - && ++requires > h->requires) - return NULL; - } - } - } + if (indirect_require_tag() != h->require_tag) + return MY_CXT.global_code; #endif /* I_WORKAROUND_REQUIRE_PROPAGATION */ return I_HINT_CODE(h); @@ -379,12 +437,20 @@ STATIC U32 indirect_hash = 0; STATIC SV *indirect_hint(pTHX) { #define indirect_hint() indirect_hint(aTHX) - SV *hint; + SV *hint = NULL; if (IN_PERL_RUNTIME) return NULL; -#if I_HAS_PERL(5, 9, 5) +#if I_HAS_PERL(5, 10, 0) || defined(PL_parser) + if (!PL_parser) + return NULL; +#endif + +#ifdef cop_hints_fetch_pvn + hint = cop_hints_fetch_pvn(PL_curcop, __PACKAGE__, __PACKAGE_LEN__, + indirect_hash, 0); +#elif I_HAS_PERL(5, 9, 5) hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, NULL, __PACKAGE__, __PACKAGE_LEN__, @@ -392,37 +458,29 @@ STATIC SV *indirect_hint(pTHX) { indirect_hash); #else { - SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__, - indirect_hash); - if (!val) - return 0; - hint = *val; + SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__, 0); + if (val) + hint = *val; } #endif - return indirect_detag(hint); + + if (hint && SvIOK(hint)) + return indirect_detag(hint); + else { + dMY_CXT; + return MY_CXT.global_code; + } } /* ... op -> source position ............................................... */ -STATIC void indirect_map_store(pTHX_ const OP *o, const char *src, SV *sv, line_t line) { -#define indirect_map_store(O, S, N, L) indirect_map_store(aTHX_ (O), (S), (N), (L)) +STATIC void indirect_map_store(pTHX_ const OP *o, STRLEN pos, SV *sv, line_t line) { +#define indirect_map_store(O, P, N, L) indirect_map_store(aTHX_ (O), (P), (N), (L)) indirect_op_info_t *oi; const char *s; STRLEN len; dMY_CXT; - /* When lex_inwhat is set, we're in a quotelike environment (qq, qr, but not q) - * In this case the linestr has temporarly changed, but the old buffer should - * still be alive somewhere. */ - - if (!PL_lex_inwhat) { - const char *pl_linestr = SvPVX_const(PL_linestr); - if (MY_CXT.linestr != pl_linestr) { - ptable_clear(MY_CXT.map); - MY_CXT.linestr = pl_linestr; - } - } - if (!(oi = ptable_fetch(MY_CXT.map, o))) { Newx(oi, 1, indirect_op_info_t); ptable_store(MY_CXT.map, o, oi); @@ -445,18 +503,14 @@ STATIC void indirect_map_store(pTHX_ const OP *o, const char *src, SV *sv, line_ Copy(s, oi->buf, len, char); oi->len = len; - oi->pos = src; + oi->pos = pos; oi->line = line; } STATIC const indirect_op_info_t *indirect_map_fetch(pTHX_ const OP *o) { #define indirect_map_fetch(O) indirect_map_fetch(aTHX_ (O)) - const indirect_op_info_t *val; dMY_CXT; - if (MY_CXT.linestr != SvPVX_const(PL_linestr)) - return NULL; - return ptable_fetch(MY_CXT.map, o); } @@ -464,33 +518,48 @@ STATIC void indirect_map_delete(pTHX_ const OP *o) { #define indirect_map_delete(O) indirect_map_delete(aTHX_ (O)) dMY_CXT; - ptable_store(MY_CXT.map, o, NULL); + ptable_delete(MY_CXT.map, o); } /* --- Check functions ----------------------------------------------------- */ -STATIC const char *indirect_find(pTHX_ SV *sv, const char *s) { -#define indirect_find(N, S) indirect_find(aTHX_ (N), (S)) - STRLEN len; - const char *p = NULL, *r = SvPV_const(sv, len); - - if (len >= 1 && *r == '$') { - ++r; - --len; - s = strchr(s, '$'); - if (!s) - return NULL; +STATIC int indirect_find(pTHX_ SV *name_sv, const char *line_bufptr, STRLEN *name_pos) { +#define indirect_find(NSV, LBP, NP) indirect_find(aTHX_ (NSV), (LBP), (NP)) + STRLEN name_len, line_len; + const char *name, *name_end; + const char *line, *line_end; + const char *p; + + line = SvPV_const(PL_linestr, line_len); + line_end = line + line_len; + + name = SvPV_const(name_sv, name_len); + if (name_len >= 1 && *name == '$') { + ++name; + --name_len; + while (line_bufptr < line_end && *line_bufptr != '$') + ++line_bufptr; + if (line_bufptr >= line_end) + return 0; } + name_end = name + name_len; - p = strstr(s, r); - while (p) { - p += len; - if (!isALNUM(*p)) + p = line_bufptr; + while (1) { + p = ninstr(p, line_end, name, name_end); + if (!p) + return 0; + if (!isALNUM(p[name_len])) break; - p = strstr(p + 1, r); + /* p points to a word that has name as prefix, skip the rest of the word */ + p += name_len + 1; + while (isALNUM(*p)) + ++p; } - return p; + *name_pos = p - line; + + return 1; } /* ... ck_const ............................................................ */ @@ -498,14 +567,37 @@ STATIC const char *indirect_find(pTHX_ SV *sv, const char *s) { STATIC OP *(*indirect_old_ck_const)(pTHX_ OP *) = 0; STATIC OP *indirect_ck_const(pTHX_ OP *o) { - o = CALL_FPTR(indirect_old_ck_const)(aTHX_ o); + o = indirect_old_ck_const(aTHX_ o); if (indirect_hint()) { SV *sv = cSVOPo_sv; + if (SvPOK(sv) && (SvTYPE(sv) >= SVt_PV)) { - const char *s = indirect_find(sv, PL_oldbufptr); - indirect_map_store(o, s, sv, CopLINE(&PL_compiling)); - return o; + STRLEN pos; + + if (indirect_find(sv, PL_oldbufptr, &pos)) { + STRLEN len; + + /* If the constant is equal to the current package name, try to look for + * a "__PACKAGE__" coming before what we got. We only need to check this + * when we already had a match because __PACKAGE__ can only appear in + * direct method calls ("new __PACKAGE__" is a syntax error). */ + len = SvCUR(sv); + if (len == HvNAMELEN_get(PL_curstash) + && memcmp(SvPVX(sv), HvNAME_get(PL_curstash), len) == 0) { + STRLEN pos_pkg; + SV *pkg = sv_newmortal(); + sv_setpvn(pkg, "__PACKAGE__", sizeof("__PACKAGE__")-1); + + if (indirect_find(pkg, PL_oldbufptr, &pos_pkg) && pos_pkg < pos) { + sv = pkg; + pos = pos_pkg; + } + } + + indirect_map_store(o, pos, sv, CopLINE(&PL_compiling)); + return o; + } } } @@ -521,8 +613,8 @@ STATIC OP *indirect_ck_rv2sv(pTHX_ OP *o) { if (indirect_hint()) { OP *op = cUNOPo->op_first; SV *sv; - const char *name = NULL, *s; - STRLEN len; + const char *name = NULL; + STRLEN pos, len; OPCODE type = (OPCODE) op->op_type; switch (type) { @@ -545,8 +637,8 @@ STATIC OP *indirect_ck_rv2sv(pTHX_ OP *o) { sv = sv_2mortal(newSVpvn("$", 1)); sv_catpvn_nomg(sv, name, len); - s = indirect_find(sv, PL_oldbufptr); - if (!s) { /* If it failed, retry without the current stash */ + if (!indirect_find(sv, PL_oldbufptr, &pos)) { + /* If it failed, retry without the current stash */ const char *stash = HvNAME_get(PL_curstash); STRLEN stashlen = HvNAMELEN_get(PL_curstash); @@ -563,18 +655,18 @@ STATIC OP *indirect_ck_rv2sv(pTHX_ OP *o) { sv_setpvn(sv, "$", 1); stashlen += 2; sv_catpvn_nomg(sv, name + stashlen, len - stashlen); - s = indirect_find(sv, PL_oldbufptr); - if (!s) + if (!indirect_find(sv, PL_oldbufptr, &pos)) goto done; } - o = CALL_FPTR(indirect_old_ck_rv2sv)(aTHX_ o); - indirect_map_store(o, s, sv, CopLINE(&PL_compiling)); + o = indirect_old_ck_rv2sv(aTHX_ o); + + indirect_map_store(o, pos, sv, CopLINE(&PL_compiling)); return o; } done: - o = CALL_FPTR(indirect_old_ck_rv2sv)(aTHX_ o); + o = indirect_old_ck_rv2sv(aTHX_ o); indirect_map_delete(o); return o; @@ -585,7 +677,7 @@ done: STATIC OP *(*indirect_old_ck_padany)(pTHX_ OP *) = 0; STATIC OP *indirect_ck_padany(pTHX_ OP *o) { - o = CALL_FPTR(indirect_old_ck_padany)(aTHX_ o); + o = indirect_old_ck_padany(aTHX_ o); if (indirect_hint()) { SV *sv; @@ -597,7 +689,8 @@ STATIC OP *indirect_ck_padany(pTHX_ OP *o) { while (s < t && isSPACE(*t)) --t; sv = sv_2mortal(newSVpvn("$", 1)); sv_catpvn_nomg(sv, s, t - s + 1); - indirect_map_store(o, s, sv, CopLINE(&PL_compiling)); + indirect_map_store(o, s - SvPVX_const(PL_linestr), + sv, CopLINE(&PL_compiling)); return o; } } @@ -618,10 +711,11 @@ STATIC OP *indirect_ck_scope(pTHX_ OP *o) { case OP_SCOPE: old_ck = indirect_old_ck_scope; break; case OP_LINESEQ: old_ck = indirect_old_ck_lineseq; break; } - o = CALL_FPTR(old_ck)(aTHX_ o); + o = old_ck(aTHX_ o); if (indirect_hint()) { - indirect_map_store(o, PL_oldbufptr, NULL, CopLINE(&PL_compiling)); + indirect_map_store(o, PL_oldbufptr - SvPVX_const(PL_linestr), + NULL, CopLINE(&PL_compiling)); return o; } @@ -639,55 +733,82 @@ STATIC OP *(*indirect_old_ck_method)(pTHX_ OP *) = 0; STATIC OP *indirect_ck_method(pTHX_ OP *o) { if (indirect_hint()) { OP *op = cUNOPo->op_first; - const indirect_op_info_t *oi = indirect_map_fetch(op); - const char *s = NULL; - line_t line; - SV *sv; - if (oi && (s = oi->pos)) { - sv = sv_2mortal(newSVpvn(oi->buf, oi->len)); - line = oi->line; /* Keep the old line so that we really point to the first */ - } else { - sv = cSVOPx_sv(op); - if (!SvPOK(sv) || (SvTYPE(sv) < SVt_PV)) + /* Indirect method call is only possible when the method is a bareword, so + * don't trip up on $obj->$meth. */ + if (op && op->op_type == OP_CONST) { + const indirect_op_info_t *oi = indirect_map_fetch(op); + STRLEN pos; + line_t line; + SV *sv; + + if (!oi) goto done; - sv = sv_mortalcopy(sv); - s = indirect_find(sv, PL_oldbufptr); - line = CopLINE(&PL_compiling); - } - o = CALL_FPTR(indirect_old_ck_method)(aTHX_ o); - /* o may now be a method_named */ + sv = sv_2mortal(newSVpvn(oi->buf, oi->len)); + pos = oi->pos; + /* Keep the old line so that we really point to the first line of the + * expression. */ + line = oi->line; + + o = indirect_old_ck_method(aTHX_ o); + /* o may now be a method_named */ - indirect_map_store(o, s, sv, line); - return o; + indirect_map_store(o, pos, sv, line); + return o; + } } done: - o = CALL_FPTR(indirect_old_ck_method)(aTHX_ o); + o = indirect_old_ck_method(aTHX_ o); indirect_map_delete(o); return o; } -/* ... ck_entersub ......................................................... */ +/* ... ck_method_named ..................................................... */ -STATIC int indirect_is_indirect(const indirect_op_info_t *moi, const indirect_op_info_t *ooi) { - if (moi->pos > ooi->pos) - return 0; +/* "use foo/no foo" compiles its call to import/unimport directly to a + * method_named op. */ - if (moi->pos == ooi->pos) - return moi->len == ooi->len && !memcmp(moi->buf, ooi->buf, moi->len); +STATIC OP *(*indirect_old_ck_method_named)(pTHX_ OP *) = 0; - return 1; +STATIC OP *indirect_ck_method_named(pTHX_ OP *o) { + if (indirect_hint()) { + STRLEN pos; + line_t line; + SV *sv; + + sv = cSVOPo_sv; + if (!SvPOK(sv) || (SvTYPE(sv) < SVt_PV)) + goto done; + sv = sv_mortalcopy(sv); + + if (!indirect_find(sv, PL_oldbufptr, &pos)) + goto done; + line = CopLINE(&PL_compiling); + + o = indirect_old_ck_method_named(aTHX_ o); + + indirect_map_store(o, pos, sv, line); + return o; + } + +done: + o = indirect_old_ck_method_named(aTHX_ o); + + indirect_map_delete(o); + return o; } +/* ... ck_entersub ......................................................... */ + STATIC OP *(*indirect_old_ck_entersub)(pTHX_ OP *) = 0; STATIC OP *indirect_ck_entersub(pTHX_ OP *o) { SV *code = indirect_hint(); - o = CALL_FPTR(indirect_old_ck_entersub)(aTHX_ o); + o = indirect_old_ck_entersub(aTHX_ o); if (code) { const indirect_op_info_t *moi, *ooi; @@ -724,14 +845,18 @@ STATIC OP *indirect_ck_entersub(pTHX_ OP *o) { goto done; moi = indirect_map_fetch(mop); - if (!(moi && moi->pos)) + if (!moi) goto done; ooi = indirect_map_fetch(oop); - if (!(ooi && ooi->pos)) + if (!ooi) goto done; - if (indirect_is_indirect(moi, ooi)) { + /* When positions are identical, the method and the object must have the + * same name. But it also means that it is an indirect call, as "foo->foo" + * results in different positions. */ + if ( moi->line < ooi->line + || (moi->line == ooi->line && moi->pos <= ooi->pos)) { SV *file; dSP; @@ -768,9 +893,6 @@ done: STATIC U32 indirect_initialized = 0; STATIC void indirect_teardown(pTHX_ void *root) { -#define indirect_teardown() indirect_teardown(aTHX) - dMY_CXT; - if (!indirect_initialized) return; @@ -779,26 +901,23 @@ STATIC void indirect_teardown(pTHX_ void *root) { return; #endif - ptable_free(MY_CXT.map); + { + dMY_CXT; + ptable_free(MY_CXT.map); #if I_THREADSAFE - ptable_hints_free(MY_CXT.tbl); + ptable_hints_free(MY_CXT.tbl); #endif + } + + indirect_ck_restore(OP_CONST, &indirect_old_ck_const); + indirect_ck_restore(OP_RV2SV, &indirect_old_ck_rv2sv); + indirect_ck_restore(OP_PADANY, &indirect_old_ck_padany); + indirect_ck_restore(OP_SCOPE, &indirect_old_ck_scope); + indirect_ck_restore(OP_LINESEQ, &indirect_old_ck_lineseq); - PL_check[OP_CONST] = MEMBER_TO_FPTR(indirect_old_ck_const); - indirect_old_ck_const = 0; - PL_check[OP_RV2SV] = MEMBER_TO_FPTR(indirect_old_ck_rv2sv); - indirect_old_ck_rv2sv = 0; - PL_check[OP_PADANY] = MEMBER_TO_FPTR(indirect_old_ck_padany); - indirect_old_ck_padany = 0; - PL_check[OP_SCOPE] = MEMBER_TO_FPTR(indirect_old_ck_scope); - indirect_old_ck_scope = 0; - PL_check[OP_LINESEQ] = MEMBER_TO_FPTR(indirect_old_ck_lineseq); - indirect_old_ck_lineseq = 0; - - PL_check[OP_METHOD] = MEMBER_TO_FPTR(indirect_old_ck_method); - indirect_old_ck_method = 0; - PL_check[OP_ENTERSUB] = MEMBER_TO_FPTR(indirect_old_ck_entersub); - indirect_old_ck_entersub = 0; + indirect_ck_restore(OP_METHOD, &indirect_old_ck_method); + indirect_ck_restore(OP_METHOD_NAMED, &indirect_old_ck_method_named); + indirect_ck_restore(OP_ENTERSUB, &indirect_old_ck_entersub); indirect_initialized = 0; } @@ -808,29 +927,28 @@ STATIC void indirect_setup(pTHX) { if (indirect_initialized) return; - MY_CXT_INIT; + { + MY_CXT_INIT; #if I_THREADSAFE - MY_CXT.tbl = ptable_new(); - MY_CXT.owner = aTHX; + MY_CXT.tbl = ptable_new(); + MY_CXT.owner = aTHX; #endif - MY_CXT.map = ptable_new(); - MY_CXT.linestr = NULL; - - indirect_old_ck_const = PL_check[OP_CONST]; - PL_check[OP_CONST] = MEMBER_TO_FPTR(indirect_ck_const); - indirect_old_ck_rv2sv = PL_check[OP_RV2SV]; - PL_check[OP_RV2SV] = MEMBER_TO_FPTR(indirect_ck_rv2sv); - indirect_old_ck_padany = PL_check[OP_PADANY]; - PL_check[OP_PADANY] = MEMBER_TO_FPTR(indirect_ck_padany); - indirect_old_ck_scope = PL_check[OP_SCOPE]; - PL_check[OP_SCOPE] = MEMBER_TO_FPTR(indirect_ck_scope); - indirect_old_ck_lineseq = PL_check[OP_LINESEQ]; - PL_check[OP_LINESEQ] = MEMBER_TO_FPTR(indirect_ck_scope); - - indirect_old_ck_method = PL_check[OP_METHOD]; - PL_check[OP_METHOD] = MEMBER_TO_FPTR(indirect_ck_method); - indirect_old_ck_entersub = PL_check[OP_ENTERSUB]; - PL_check[OP_ENTERSUB] = MEMBER_TO_FPTR(indirect_ck_entersub); + MY_CXT.map = ptable_new(); + MY_CXT.global_code = NULL; + } + + indirect_ck_replace(OP_CONST, indirect_ck_const, &indirect_old_ck_const); + indirect_ck_replace(OP_RV2SV, indirect_ck_rv2sv, &indirect_old_ck_rv2sv); + indirect_ck_replace(OP_PADANY, indirect_ck_padany, &indirect_old_ck_padany); + indirect_ck_replace(OP_SCOPE, indirect_ck_scope, &indirect_old_ck_scope); + indirect_ck_replace(OP_LINESEQ, indirect_ck_scope, &indirect_old_ck_lineseq); + + indirect_ck_replace(OP_METHOD, indirect_ck_method, + &indirect_old_ck_method); + indirect_ck_replace(OP_METHOD_NAMED, indirect_ck_method_named, + &indirect_old_ck_method_named); + indirect_ck_replace(OP_ENTERSUB, indirect_ck_entersub, + &indirect_old_ck_entersub); #if I_MULTIPLICITY call_atexit(indirect_teardown, aTHX); @@ -858,6 +976,7 @@ BOOT: stash = gv_stashpvn(__PACKAGE__, __PACKAGE_LEN__, 1); newCONSTSUB(stash, "I_THREADSAFE", newSVuv(I_THREADSAFE)); + newCONSTSUB(stash, "I_FORKSAFE", newSVuv(I_FORKSAFE)); } indirect_setup(); @@ -870,29 +989,25 @@ CLONE(...) PROTOTYPE: DISABLE PREINIT: ptable *t; - int *level; -CODE: + SV *global_code_dup; +PPCODE: { my_cxt_t ud; dMY_CXT; ud.tbl = t = ptable_new(); ud.owner = MY_CXT.owner; ptable_walk(MY_CXT.tbl, indirect_ptable_clone, &ud); + global_code_dup = indirect_clone(MY_CXT.global_code, MY_CXT.owner); } { MY_CXT_CLONE; - MY_CXT.map = ptable_new(); - MY_CXT.linestr = NULL; - MY_CXT.tbl = t; - MY_CXT.owner = aTHX; - } - { - level = PerlMemShared_malloc(sizeof *level); - *level = 1; - LEAVE; - SAVEDESTRUCTOR_X(indirect_thread_cleanup, level); - ENTER; + MY_CXT.map = ptable_new(); + MY_CXT.tbl = t; + MY_CXT.owner = aTHX; + MY_CXT.global_code = global_code_dup; } + reap(3, indirect_thread_cleanup, NULL); + XSRETURN(0); #endif @@ -903,3 +1018,18 @@ CODE: RETVAL = indirect_tag(value); OUTPUT: RETVAL + +void +_global(SV *code) +PROTOTYPE: $ +PPCODE: + if (!SvOK(code)) + code = NULL; + else if (SvROK(code)) + code = SvRV(code); + { + dMY_CXT; + SvREFCNT_dec(MY_CXT.global_code); + MY_CXT.global_code = SvREFCNT_inc(code); + } + XSRETURN(0);