X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2Findirect.git;a=blobdiff_plain;f=indirect.xs;h=e1961194bf1585b083f947d0201ceaca4bfed003;hp=f7b22d35696776b29abf9045c3b31153bf649430;hb=4e6baf6fb7035144cc8ae87da292f7db4e9f5713;hpb=4fdc595f5c3de054976ac16886f65e8d78525100 diff --git a/indirect.xs b/indirect.xs index f7b22d3..e196119 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 @@ -84,7 +88,7 @@ #endif #ifndef I_WORKAROUND_REQUIRE_PROPAGATION -# define I_WORKAROUND_REQUIRE_PROPAGATION !I_HAS_PERL(5, 12, 0) +# define I_WORKAROUND_REQUIRE_PROPAGATION !I_HAS_PERL(5, 10, 1) #endif /* ... Thread safety and multiplicity ...................................... */ @@ -182,10 +186,10 @@ typedef SV indirect_hint_t; * thread cleanup. */ typedef struct { + char *buf; STRLEN pos; STRLEN size; STRLEN len; - char *buf; line_t line; } indirect_op_info_t; @@ -212,6 +216,7 @@ typedef struct { tTHX owner; #endif ptable *map; + SV *global_code; } my_cxt_t; START_MY_CXT @@ -224,6 +229,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(); @@ -253,7 +261,6 @@ STATIC void indirect_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) { h2 = PerlMemShared_malloc(sizeof *h2); h2->code = indirect_clone(h1->code, ud->owner); - SvREFCNT_inc(h2->code); #if I_WORKAROUND_REQUIRE_PROPAGATION h2->require_tag = PTR2IV(indirect_clone(INT2PTR(SV *, h1->require_tag), ud->owner)); @@ -262,7 +269,6 @@ STATIC void indirect_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) { #else /* I_HINT_STRUCT */ h2 = indirect_clone(h1, ud->owner); - SvREFCNT_inc(h2); #endif /* !I_HINT_STRUCT */ @@ -274,6 +280,7 @@ STATIC void indirect_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) { STATIC void indirect_thread_cleanup(pTHX_ void *ud) { dMY_CXT; + SvREFCNT_dec(MY_CXT.global_code); ptable_free(MY_CXT.map); ptable_hints_free(MY_CXT.tbl); } @@ -335,7 +342,7 @@ STATIC SV *indirect_tag(pTHX_ SV *value) { value = SvRV(value); if (SvTYPE(value) >= SVt_PVCV) { code = value; - SvREFCNT_inc_simple_NN(code); + SvREFCNT_inc_simple_void_NN(code); } } @@ -365,21 +372,18 @@ 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 (!(hint && SvIOK(hint))) - return NULL; +#if I_THREADSAFE || I_WORKAROUND_REQUIRE_PROPAGATION + dMY_CXT; +#endif h = INT2PTR(indirect_hint_t *, SvIVX(hint)); #if I_THREADSAFE - { - dMY_CXT; - h = ptable_fetch(MY_CXT.tbl, h); - } + h = ptable_fetch(MY_CXT.tbl, h); #endif /* I_THREADSAFE */ #if I_WORKAROUND_REQUIRE_PROPAGATION if (indirect_require_tag() != h->require_tag) - return NULL; + return MY_CXT.global_code; #endif /* I_WORKAROUND_REQUIRE_PROPAGATION */ return I_HINT_CODE(h); @@ -389,16 +393,39 @@ STATIC U32 indirect_hash = 0; STATIC SV *indirect_hint(pTHX) { #define indirect_hint() indirect_hint(aTHX) - SV **val; + SV *hint = NULL; if (IN_PERL_RUNTIME) return NULL; - val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__, indirect_hash); - if (!val) +#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__, + 0, + indirect_hash); +#else + { + SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__, 0); + if (val) + hint = *val; + } +#endif - return indirect_detag(*val); + if (hint && SvIOK(hint)) + return indirect_detag(hint); + else { + dMY_CXT; + return MY_CXT.global_code; + } } /* ... op -> source position ............................................... */ @@ -452,33 +479,66 @@ STATIC void indirect_map_delete(pTHX_ const OP *o) { /* --- Check functions ----------------------------------------------------- */ -STATIC int indirect_find(pTHX_ SV *sv, const char *s, STRLEN *pos) { -#define indirect_find(N, S, P) indirect_find(aTHX_ (N), (S), (P)) - STRLEN len; - const char *p, *r = SvPV_const(sv, len); +STATIC STRLEN indirect_nextline(const char *s, STRLEN len) { + STRLEN i; + + for (i = 0; i < len; ++i) { + if (s[i] == '\n') { + ++i; + while (i < len && s[i] == '\r') + ++i; + break; + } + } + + return i; +} - if (len >= 1 && *r == '$') { - ++r; - --len; - s = strchr(s, '$'); - if (!s) +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, *t, *u; + + 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 = s; + p = line_bufptr; while (1) { - p = strstr(p, r); + p = ninstr(p, line_end, name, name_end); if (!p) return 0; - if (!isALNUM(p[len])) + if (!isALNUM(p[name_len])) break; - /* p points to a word that has r as prefix, skip the rest of the word */ - p += len + 1; + /* p points to a word that has name as prefix, skip the rest of the word */ + p += name_len + 1; while (isALNUM(*p)) ++p; } - *pos = p - SvPVX_const(PL_linestr); + t = line; + u = t; + while (t <= p) { + STRLEN i = indirect_nextline(t, line_len); + if (i >= line_len) + break; + u = t; + t += i; + line_len -= i; + } + *name_pos = p - u; return 1; } @@ -757,7 +817,8 @@ STATIC OP *indirect_ck_entersub(pTHX_ OP *o) { /* 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->pos <= ooi->pos) { + if ( moi->line < ooi->line + || (moi->line == ooi->line && moi->pos <= ooi->pos)) { SV *file; dSP; @@ -839,10 +900,11 @@ STATIC void indirect_setup(pTHX) { { 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.map = ptable_new(); + MY_CXT.global_code = NULL; } indirect_old_ck_const = PL_check[OP_CONST]; @@ -902,6 +964,7 @@ CLONE(...) PROTOTYPE: DISABLE PREINIT: ptable *t; + SV *global_code_dup; PPCODE: { my_cxt_t ud; @@ -909,12 +972,14 @@ PPCODE: 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.tbl = t; - MY_CXT.owner = aTHX; + 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); @@ -928,3 +993,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);