X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2Findirect.git;a=blobdiff_plain;f=indirect.xs;h=6203d97a4d74679471f6e733771c711aa63c5c2c;hp=a9012cdf062582057bbc6e80a72fc83cfc4b6116;hb=0df47659c67c30deca9fc06d6c7643a886ddb7d8;hpb=9e7e0702d84f54976fa798516817f55e342fe0be diff --git a/indirect.xs b/indirect.xs index a9012cd..6203d97 100644 --- a/indirect.xs +++ b/indirect.xs @@ -6,6 +6,19 @@ #include "perl.h" #include "XSUB.h" +#define __PACKAGE__ "indirect" +#define __PACKAGE_LEN__ (sizeof(__PACKAGE__)-1) + +/* --- Compatibility wrappers ---------------------------------------------- */ + +#ifndef NOOP +# define NOOP +#endif + +#ifndef dNOOP +# define dNOOP +#endif + #ifndef SvPV_const # define SvPV_const SvPV #endif @@ -18,40 +31,259 @@ # define SvPVX_const SvPVX #endif -/* ... Hints ............................................................... */ +#ifndef sv_catpvn_nomg +# define sv_catpvn_nomg sv_catpvn +#endif + +#ifndef HvNAME_get +# define HvNAME_get(H) HvNAME(H) +#endif + +#ifndef HvNAMELEN_get +# define HvNAMELEN_get(H) strlen(HvNAME_get(H)) +#endif + +#ifndef SvIS_FREED +# define SvIS_FREED(sv) ((sv)->sv_flags == SVTYPEMASK) +#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) +# ifndef PL_lex_inwhat +# define PL_lex_inwhat PL_parser->lex_inwhat +# endif +# ifndef PL_linestr +# define PL_linestr PL_parser->linestr +# endif +# ifndef PL_bufptr +# define PL_bufptr PL_parser->bufptr +# endif +# ifndef PL_oldbufptr +# define PL_oldbufptr PL_parser->oldbufptr +# endif +#else +# ifndef PL_lex_inwhat +# define PL_lex_inwhat PL_Ilex_inwhat +# endif +# ifndef PL_linestr +# define PL_linestr PL_Ilinestr +# endif +# ifndef PL_bufptr +# define PL_bufptr PL_Ibufptr +# endif +# ifndef PL_oldbufptr +# define PL_oldbufptr PL_Ioldbufptr +# endif +#endif + +/* ... Thread safety and multiplicity ...................................... */ + +#ifndef I_MULTIPLICITY +# if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT) +# define I_MULTIPLICITY 1 +# else +# define I_MULTIPLICITY 0 +# endif +#endif +#if I_MULTIPLICITY && !defined(tTHX) +# define tTHX PerlInterpreter* +#endif + +#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)) +# define I_THREADSAFE 1 +# ifndef MY_CXT_CLONE +# define MY_CXT_CLONE \ + dMY_CXT_SV; \ + my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1)); \ + Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t); \ + sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) +# endif +#else +# define I_THREADSAFE 0 +# undef dMY_CXT +# define dMY_CXT dNOOP +# undef MY_CXT +# define MY_CXT indirect_globaldata +# undef START_MY_CXT +# define START_MY_CXT STATIC my_cxt_t MY_CXT; +# undef MY_CXT_INIT +# define MY_CXT_INIT NOOP +# undef MY_CXT_CLONE +# define MY_CXT_CLONE NOOP +#endif + +/* --- Helpers ------------------------------------------------------------- */ + +/* ... Pointer table ....................................................... */ + +#define PTABLE_NAME ptable +#define PTABLE_VAL_FREE(V) if ((V) && !SvIS_FREED((SV *) (V))) SvREFCNT_dec(V) + +#define pPTBL pTHX +#define pPTBL_ pTHX_ +#define aPTBL aTHX +#define aPTBL_ aTHX_ + +#include "ptable.h" + +#define ptable_store(T, K, V) ptable_store(aTHX_ (T), (K), (V)) +#define ptable_clear(T) ptable_clear(aTHX_ (T)) +#define ptable_free(T) ptable_free(aTHX_ (T)) + +/* ... Thread-safe hints ................................................... */ + +#define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION + +#if I_THREADSAFE + +typedef struct { + ptable *tbl; + ptable *map; + tTHX owner; + const char *linestr; +} my_cxt_t; + +#else + +typedef struct { + ptable *map; + const char *linestr; +} my_cxt_t; + +#endif /* I_THREADSAFE */ + +START_MY_CXT + +#if I_THREADSAFE + +STATIC void indirect_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) { + my_cxt_t *ud = ud_; + SV *val = ent->val; + + if (ud->owner != aTHX) { + CLONE_PARAMS param; + AV *stashes = (SvTYPE(val) == SVt_PVHV && HvNAME_get(val)) ? newAV() : NULL; + param.stashes = stashes; + param.flags = 0; + param.proto_perl = ud->owner; + val = sv_dup(val, ¶m); + if (stashes) { + av_undef(stashes); + SvREFCNT_dec(stashes); + } + } + + ptable_store(ud->tbl, ent->key, val); + SvREFCNT_inc(val); +} + +STATIC void indirect_thread_cleanup(pTHX_ void *); + +STATIC void indirect_thread_cleanup(pTHX_ void *ud) { + int *level = ud; + SV *id; + + if (*level) { + *level = 0; + LEAVE; + SAVEDESTRUCTOR_X(indirect_thread_cleanup, level); + ENTER; + } else { + dMY_CXT; + PerlMemShared_free(level); + ptable_free(MY_CXT.map); + ptable_free(MY_CXT.tbl); + } +} + +STATIC SV *indirect_tag(pTHX_ SV *value) { +#define indirect_tag(V) indirect_tag(aTHX_ (V)) + dMY_CXT; + + value = SvOK(value) && SvROK(value) ? SvRV(value) : NULL; + /* 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 value pointer as the key itself. */ + ptable_store(MY_CXT.tbl, value, value); + SvREFCNT_inc(value); + + return newSVuv(PTR2UV(value)); +} + +STATIC SV *indirect_detag(pTHX_ const SV *hint) { +#define indirect_detag(H) indirect_detag(aTHX_ (H)) + void *tag; + SV *value; + + if (!hint || !SvOK(hint) || !SvIOK(hint)) + croak("Wrong hint"); + + tag = INT2PTR(void *, SvIVX(hint)); + { + dMY_CXT; + value = ptable_fetch(MY_CXT.tbl, tag); + } + + return value; +} + +#else + +STATIC SV *indirect_tag(pTHX_ SV *value) { +#define indirect_tag(V) indirect_tag(aTHX_ (V)) + UV tag = 0; + + if (SvOK(value) && SvROK(value)) { + value = SvRV(value); + SvREFCNT_inc(value); + tag = PTR2UV(value); + } + + return newSVuv(tag); +} + +#define indirect_detag(H) INT2PTR(SV *, SvUVX(H)) + +#endif /* I_THREADSAFE */ STATIC U32 indirect_hash = 0; -STATIC UV indirect_hint(pTHX) { +STATIC SV *indirect_hint(pTHX) { #define indirect_hint() indirect_hint(aTHX) - SV *id = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, - NULL, - "indirect", 8, - 0, - indirect_hash); - return SvIOK(id) ? SvUV(id) : 0; + SV *id; +#if I_HAS_PERL(5, 10, 0) + id = 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__, + indirect_hash); + if (!val) + return 0; + id = *val; +#endif + return (id && SvOK(id)) ? id : NULL; } /* ... op -> source position ............................................... */ -STATIC HV *indirect_map = NULL; -STATIC const char *indirect_linestr = NULL; - STATIC void indirect_map_store(pTHX_ const OP *o, const char *src, SV *sv) { #define indirect_map_store(O, S, N) indirect_map_store(aTHX_ (O), (S), (N)) - char buf[32]; - const char *pl_linestr; + dMY_CXT; SV *val; /* 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_parser->lex_inwhat) { - pl_linestr = SvPVX_const(PL_parser->linestr); - if (indirect_linestr != pl_linestr) { - hv_clear(indirect_map); - indirect_linestr = pl_linestr; + 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; } } @@ -60,35 +292,42 @@ STATIC void indirect_map_store(pTHX_ const OP *o, const char *src, SV *sv) { SvUVX(val) = PTR2UV(src); SvIOK_on(val); SvIsUV_on(val); - if (!hv_store(indirect_map, buf, sprintf(buf, "%u", PTR2UV(o)), val, 0)) - SvREFCNT_dec(val); + + ptable_store(MY_CXT.map, o, val); } STATIC const char *indirect_map_fetch(pTHX_ const OP *o, SV ** const name) { #define indirect_map_fetch(O, S) indirect_map_fetch(aTHX_ (O), (S)) - char buf[32]; - SV **val; + dMY_CXT; + SV *val; - if (indirect_linestr != SvPVX_const(PL_parser->linestr)) + if (MY_CXT.linestr != SvPVX_const(PL_linestr)) return NULL; - val = hv_fetch(indirect_map, buf, sprintf(buf, "%u", PTR2UV(o)), 0); + val = ptable_fetch(MY_CXT.map, o); if (!val) { *name = NULL; return NULL; } - *name = *val; - return INT2PTR(const char *, SvUVX(*val)); + *name = val; + return INT2PTR(const char *, SvUVX(val)); } +/* --- 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) - return s; + if (len >= 1 && *r == '$') { + ++r; + --len; + s = strchr(s, '$'); + if (!s) + return NULL; + } p = strstr(s, r); while (p) { @@ -106,13 +345,15 @@ 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); + if (indirect_hint()) { SV *sv = cSVOPo_sv; if (SvPOK(sv) && (SvTYPE(sv) >= SVt_PV)) - indirect_map_store(o, indirect_find(sv, PL_parser->oldbufptr), sv); + indirect_map_store(o, indirect_find(sv, PL_oldbufptr), sv); } - return CALL_FPTR(indirect_old_ck_const)(aTHX_ o); + return o; } /* ... ck_rv2sv ............................................................ */ @@ -122,14 +363,60 @@ STATIC OP *(*indirect_old_ck_rv2sv)(pTHX_ OP *) = 0; STATIC OP *indirect_ck_rv2sv(pTHX_ OP *o) { if (indirect_hint()) { OP *op = cUNOPo->op_first; - SV *name = cSVOPx_sv(op); - if (SvPOK(name) && (SvTYPE(name) >= SVt_PV)) { - SV *sv = sv_2mortal(newSVpvn("$", 1)); - sv_catsv(sv, name); - indirect_map_store(o, indirect_find(sv, PL_parser->oldbufptr), sv); + SV *sv; + const char *name = NULL, *s; + STRLEN len; + OPCODE type = (OPCODE) op->op_type; + + switch (type) { + case OP_GV: + case OP_GVSV: { + GV *gv = cGVOPx_gv(op); + name = GvNAME(gv); + len = GvNAMELEN(gv); + break; + } + default: + if ((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP) { + SV *nsv = cSVOPx_sv(op); + if (SvPOK(nsv) && (SvTYPE(nsv) >= SVt_PV)) + name = SvPV_const(nsv, len); + } + } + if (!name) + goto done; + + 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 */ + const char *stash = HvNAME_get(PL_curstash); + STRLEN stashlen = HvNAMELEN_get(PL_curstash); + + if ((len < stashlen + 2) || strnNE(name, stash, stashlen) + || name[stashlen] != ':' || name[stashlen+1] != ':') { + /* Failed again ? Try to remove main */ + stash = "main"; + stashlen = 4; + if ((len < stashlen + 2) || strnNE(name, stash, stashlen) + || name[stashlen] != ':' || name[stashlen+1] != ':') + goto done; + } + + sv_setpvn(sv, "$", 1); + stashlen += 2; + sv_catpvn_nomg(sv, name + stashlen, len - stashlen); + s = indirect_find(sv, PL_oldbufptr); + if (!s) + goto done; } + + o = CALL_FPTR(indirect_old_ck_rv2sv)(aTHX_ o); + indirect_map_store(o, s, sv); + return o; } +done: return CALL_FPTR(indirect_old_ck_rv2sv)(aTHX_ o); } @@ -138,18 +425,23 @@ STATIC OP *indirect_ck_rv2sv(pTHX_ OP *o) { 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); + if (indirect_hint()) { SV *sv; - const char *s = PL_parser->oldbufptr, *t = PL_parser->bufptr - 1; + const char *s = PL_oldbufptr, *t = PL_bufptr - 1; while (s < t && isSPACE(*s)) ++s; - while (t > s && isSPACE(*t)) --t; - sv = sv_2mortal(newSVpvn(s, t - s + 1)); - - indirect_map_store(o, s, sv); + if (*s == '$' && ++s <= t) { + while (s < t && isSPACE(*s)) ++s; + 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); + } } - return CALL_FPTR(indirect_old_ck_padany)(aTHX_ o); + return o; } /* ... ck_method ........................................................... */ @@ -166,7 +458,7 @@ STATIC OP *indirect_ck_method(pTHX_ OP *o) { if (!SvPOK(sv) || (SvTYPE(sv) < SVt_PV)) goto done; sv = sv_mortalcopy(sv); - s = indirect_find(sv, PL_parser->oldbufptr); + s = indirect_find(sv, PL_oldbufptr); } o = CALL_FPTR(indirect_old_ck_method)(aTHX_ o); /* o may now be a method_named */ @@ -180,42 +472,69 @@ done: /* ... ck_entersub ......................................................... */ -STATIC const char indirect_msg[] = "Indirect call of method \"%s\" on object \"%s\""; - STATIC OP *(*indirect_old_ck_entersub)(pTHX_ OP *) = 0; STATIC OP *indirect_ck_entersub(pTHX_ OP *o) { - LISTOP *op; - OP *om, *oo; - UV hint = indirect_hint(); + SV *hint = indirect_hint(); + + o = CALL_FPTR(indirect_old_ck_entersub)(aTHX_ o); if (hint) { - const char *pm, *po; - SV *svm, *svo; - op = (LISTOP *) o; - while (op->op_type != OP_PUSHMARK) - op = (LISTOP *) op->op_first; - oo = op->op_sibling; - om = oo; - while (om->op_sibling) - om = om->op_sibling; - if (om->op_type == OP_METHOD) - om = cUNOPx(om)->op_first; - else if (om->op_type != OP_METHOD_NAMED) + const char *mpos, *opos; + SV *mnamesv, *onamesv; + OP *mop, *oop; + LISTOP *lop; + + oop = o; + do { + lop = (LISTOP *) oop; + if (!(lop->op_flags & OPf_KIDS)) + goto done; + oop = lop->op_first; + } while (oop->op_type != OP_PUSHMARK); + oop = oop->op_sibling; + mop = lop->op_last; + + if (mop->op_type == OP_METHOD) + mop = cUNOPx(mop)->op_first; + else if (mop->op_type != OP_METHOD_NAMED) + goto done; + + mpos = indirect_map_fetch(mop, &mnamesv); + if (!mpos) goto done; - pm = indirect_map_fetch(om, &svm); - po = indirect_map_fetch(oo, &svo); - if (pm && po && pm < po) { - const char *psvm = SvPV_nolen_const(svm), *psvo = SvPV_nolen_const(svo); - if (hint == 2) - croak(indirect_msg, psvm, psvo); - else - warn(indirect_msg, psvm, psvo); + + opos = indirect_map_fetch(oop, &onamesv); + if (!opos) + goto done; + + if (mpos < opos) { + SV *code = indirect_detag(hint); + + if (hint) { + dSP; + + ENTER; + SAVETMPS; + + PUSHMARK(SP); + EXTEND(SP, 2); + PUSHs(onamesv); + PUSHs(mnamesv); + PUTBACK; + + call_sv(code, G_VOID); + + PUTBACK; + + FREETMPS; + LEAVE; + } } } done: - return CALL_FPTR(indirect_old_ck_entersub)(aTHX_ o); + return o; } STATIC U32 indirect_initialized = 0; @@ -224,13 +543,23 @@ STATIC U32 indirect_initialized = 0; MODULE = indirect PACKAGE = indirect -PROTOTYPES: DISABLE +PROTOTYPES: ENABLE BOOT: { if (!indirect_initialized++) { - PERL_HASH(indirect_hash, "indirect", 8); - indirect_map = newHV(); + HV *stash; + + MY_CXT_INIT; + MY_CXT.map = ptable_new(); + MY_CXT.linestr = NULL; +#if I_THREADSAFE + MY_CXT.tbl = ptable_new(); + MY_CXT.owner = aTHX; +#endif + + PERL_HASH(indirect_hash, __PACKAGE__, __PACKAGE_LEN__); + 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]; @@ -241,5 +570,49 @@ BOOT: 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); + + stash = gv_stashpvn(__PACKAGE__, __PACKAGE_LEN__, 1); + newCONSTSUB(stash, "I_THREADSAFE", newSVuv(I_THREADSAFE)); } } + +#if I_THREADSAFE + +void +CLONE(...) +PROTOTYPE: DISABLE +PREINIT: + ptable *t; + int *level; +CODE: + { + 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); + } + { + 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; + } + +#endif + +SV * +_tag(SV *value) +PROTOTYPE: $ +CODE: + RETVAL = indirect_tag(value); +OUTPUT: + RETVAL