X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2Findirect.git;a=blobdiff_plain;f=indirect.xs;h=7c264c5553c7f85738675b8b801f68514c3604b7;hp=78788021af885ab2c1afaf3804c919fcd9e7f8f5;hb=f9e9f900acf1683017658778d0c234331fd36618;hpb=5a1dc0d262394646b37dc5a1e4f5ee0a1e59fc1b diff --git a/indirect.xs b/indirect.xs index 7878802..7c264c5 100644 --- a/indirect.xs +++ b/indirect.xs @@ -63,6 +63,10 @@ # define HvNAMELEN_get(H) strlen(HvNAME_get(H)) #endif +#ifndef OP_SIBLING +# define OP_SIBLING(O) ((O)->op_sibling) +#endif + #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) @@ -267,68 +271,87 @@ START_MY_CXT #if I_THREADSAFE -STATIC SV *indirect_clone(pTHX_ SV *sv, tTHX owner) { -#define indirect_clone(S, O) indirect_clone(aTHX_ (S), (O)) - CLONE_PARAMS param; - AV *stashes = NULL; - SV *dupsv; - - if (!sv) - return NULL; - - if (SvTYPE(sv) == SVt_PVHV && HvNAME_get(sv)) - stashes = newAV(); - - param.stashes = stashes; - param.flags = 0; - param.proto_perl = owner; - - dupsv = sv_dup(sv, ¶m); - - if (stashes) { - av_undef(stashes); - SvREFCNT_dec(stashes); - } - - return SvREFCNT_inc(dupsv); -} +typedef struct { + ptable *tbl; +#if I_HAS_PERL(5, 13, 2) + CLONE_PARAMS *params; +#else + CLONE_PARAMS params; +#endif +} indirect_ptable_clone_ud; + +#if I_HAS_PERL(5, 13, 2) +# define indirect_ptable_clone_ud_init(U, T, O) \ + (U).tbl = (T); \ + (U).params = Perl_clone_params_new((O), aTHX) +# define indirect_ptable_clone_ud_deinit(U) Perl_clone_params_del((U).params) +# define indirect_dup_inc(S, U) SvREFCNT_inc(sv_dup((S), (U)->params)) +#else +# define indirect_ptable_clone_ud_init(U, T, O) \ + (U).tbl = (T); \ + (U).params.stashes = newAV(); \ + (U).params.flags = 0; \ + (U).params.proto_perl = (O) +# define indirect_ptable_clone_ud_deinit(U) SvREFCNT_dec((U).params.stashes) +# define indirect_dup_inc(S, U) SvREFCNT_inc(sv_dup((S), &((U)->params))) +#endif STATIC void indirect_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) { - my_cxt_t *ud = ud_; - indirect_hint_t *h1 = ent->val; - indirect_hint_t *h2; - - if (ud->owner == aTHX) - return; + indirect_ptable_clone_ud *ud = ud_; + indirect_hint_t *h1 = ent->val; + indirect_hint_t *h2; #if I_HINT_STRUCT - h2 = PerlMemShared_malloc(sizeof *h2); - h2->code = indirect_clone(h1->code, ud->owner); + h2 = PerlMemShared_malloc(sizeof *h2); + h2->code = indirect_dup_inc(h1->code, ud); #if I_WORKAROUND_REQUIRE_PROPAGATION - h2->require_tag = PTR2IV(indirect_clone(INT2PTR(SV *, h1->require_tag), - ud->owner)); + h2->require_tag = PTR2IV(indirect_dup_inc(INT2PTR(SV *, h1->require_tag), ud)); #endif #else /* I_HINT_STRUCT */ - h2 = indirect_clone(h1, ud->owner); + h2 = indirect_dup_inc(h1, ud); #endif /* !I_HINT_STRUCT */ ptable_hints_store(ud->tbl, ent->key, h2); } -#include "reap.h" - STATIC void indirect_thread_cleanup(pTHX_ void *ud) { dMY_CXT; SvREFCNT_dec(MY_CXT.global_code); + MY_CXT.global_code = NULL; ptable_free(MY_CXT.map); + MY_CXT.map = NULL; ptable_hints_free(MY_CXT.tbl); + MY_CXT.tbl = NULL; +} + +STATIC int indirect_endav_free(pTHX_ SV *sv, MAGIC *mg) { + SAVEDESTRUCTOR_X(indirect_thread_cleanup, NULL); + + return 0; } +STATIC MGVTBL indirect_endav_vtbl = { + 0, + 0, + 0, + 0, + indirect_endav_free +#if MGf_COPY + , 0 +#endif +#if MGf_DUP + , 0 +#endif +#if MGf_LOCAL + , 0 +#endif +}; + #endif /* I_THREADSAFE */ #if I_WORKAROUND_REQUIRE_PROPAGATION @@ -576,6 +599,26 @@ STATIC OP *indirect_ck_const(pTHX_ OP *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 (PL_curstash + && len == (STRLEN) 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; } @@ -803,7 +846,7 @@ STATIC OP *indirect_ck_entersub(pTHX_ OP *o) { goto done; oop = lop->op_first; } while (oop->op_type != OP_PUSHMARK); - oop = oop->op_sibling; + oop = OP_SIBLING(oop); mop = lop->op_last; if (!oop) @@ -885,8 +928,10 @@ STATIC void indirect_teardown(pTHX_ void *root) { { dMY_CXT; ptable_free(MY_CXT.map); + MY_CXT.map = NULL; #if I_THREADSAFE ptable_hints_free(MY_CXT.tbl); + MY_CXT.tbl = NULL; #endif } @@ -971,14 +1016,16 @@ PROTOTYPE: DISABLE PREINIT: ptable *t; SV *global_code_dup; + GV *gv; PPCODE: { - my_cxt_t ud; + indirect_ptable_clone_ud ud; dMY_CXT; - ud.tbl = t = ptable_new(); - ud.owner = MY_CXT.owner; + t = ptable_new(); + indirect_ptable_clone_ud_init(ud, t, MY_CXT.owner); ptable_walk(MY_CXT.tbl, indirect_ptable_clone, &ud); - global_code_dup = indirect_clone(MY_CXT.global_code, MY_CXT.owner); + global_code_dup = indirect_dup_inc(MY_CXT.global_code, &ud); + indirect_ptable_clone_ud_deinit(ud); } { MY_CXT_CLONE; @@ -987,7 +1034,23 @@ PPCODE: MY_CXT.owner = aTHX; MY_CXT.global_code = global_code_dup; } - reap(3, indirect_thread_cleanup, NULL); + gv = gv_fetchpv(__PACKAGE__ "::_THREAD_CLEANUP", 0, SVt_PVCV); + if (gv) { + CV *cv = GvCV(gv); + if (!PL_endav) + PL_endav = newAV(); + SvREFCNT_inc(cv); + if (!av_store(PL_endav, av_len(PL_endav) + 1, (SV *) cv)) + SvREFCNT_dec(cv); + sv_magicext((SV *) PL_endav, NULL, PERL_MAGIC_ext, &indirect_endav_vtbl, NULL, 0); + } + XSRETURN(0); + +void +_THREAD_CLEANUP(...) +PROTOTYPE: DISABLE +PPCODE: + indirect_thread_cleanup(aTHX_ NULL); XSRETURN(0); #endif