X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2Findirect.git;a=blobdiff_plain;f=indirect.xs;h=284217ca0c139a31d89c0f27fb808647441c89de;hp=d21b29e4b56013f23d23045612d142be891dd63f;hb=03e565adcd2c23d08331a676767a8195f61a3cf4;hpb=4168177ad46806cfb9e0cdb522aed997215cf8b2 diff --git a/indirect.xs b/indirect.xs index d21b29e..284217c 100644 --- a/indirect.xs +++ b/indirect.xs @@ -6,23 +6,93 @@ #include "perl.h" #include "XSUB.h" -#define __PACKAGE__ "indirect" -#define __PACKAGE_LEN__ (sizeof(__PACKAGE__)-1) +/* --- XS helpers ---------------------------------------------------------- */ -/* --- Compatibility wrappers ---------------------------------------------- */ +#define XSH_PACKAGE "indirect" -#ifndef NOOP -# define NOOP -#endif +#include "xsh/caps.h" +#include "xsh/util.h" +#include "xsh/mem.h" +#include "xsh/ops.h" -#ifndef dNOOP -# define dNOOP -#endif +/* ... op => source position map ........................................... */ + +typedef struct { + char *buf; + STRLEN pos; + STRLEN size; + STRLEN len; + line_t line; +} indirect_op_info_t; + +#define PTABLE_NAME ptable +#define PTABLE_VAL_FREE(V) if (V) { indirect_op_info_t *oi = (V); XSH_LOCAL_FREE(oi->buf, oi->size, char); XSH_LOCAL_FREE(oi, 1, indirect_op_info_t); } +#define PTABLE_NEED_DELETE 1 +#define PTABLE_NEED_WALK 0 + +#include "xsh/ptable.h" + +/* XSH_LOCAL_FREE() always need aTHX */ +#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)) + +/* ... Lexical hints ....................................................... */ + +#define XSH_HINTS_TYPE_SV 1 + +#include "xsh/hints.h" + +/* ... Thread-local storage ................................................ */ + +typedef struct { + ptable *map; + SV *global_code; +} xsh_user_cxt_t; -#ifndef Newx -# define Newx(v, n, c) New(0, v, n, c) +#define XSH_THREADS_USER_CONTEXT 1 +#define XSH_THREADS_USER_CLONE_NEEDS_DUP 1 +#define XSH_THREADS_COMPILE_TIME_PROTECTION 1 + +#if XSH_THREADSAFE + +static void xsh_user_clone(pTHX_ const xsh_user_cxt_t *old_cxt, xsh_user_cxt_t *new_cxt, CLONE_PARAMS *params) { + new_cxt->map = ptable_new(32); + new_cxt->global_code = xsh_dup_inc(old_cxt->global_code, params); + + return; +} + +#endif /* XSH_THREADSAFE */ + +#include "xsh/threads.h" + +/* ... Lexical hints, continued ............................................ */ + +static SV *indirect_hint(pTHX) { +#define indirect_hint() indirect_hint(aTHX) + SV *hint; + +#if XSH_HAS_PERL(5, 10, 0) || defined(PL_parser) + if (!PL_parser) + return NULL; #endif + hint = xsh_hints_fetch(); + if (hint && SvOK(hint)) { + return xsh_hints_detag(hint); + } else { + dXSH_CXT; + if (xsh_is_loaded(&XSH_CXT)) + return XSH_CXT.global_code; + else + return NULL; + } +} + +/* --- Compatibility wrappers ---------------------------------------------- */ + #ifndef SvPV_const # define SvPV_const SvPV #endif @@ -35,8 +105,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 @@ -59,9 +133,7 @@ # define HvNAMELEN_get(H) strlen(HvNAME_get(H)) #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) +#if XSH_HAS_PERL(5, 10, 0) || defined(PL_parser) # ifndef PL_linestr # define PL_linestr PL_parser->linestr # endif @@ -71,6 +143,12 @@ # ifndef PL_oldbufptr # define PL_oldbufptr PL_parser->oldbufptr # endif +# ifndef PL_lex_inwhat +# define PL_lex_inwhat PL_parser->lex_inwhat +# endif +# ifndef PL_multi_close +# define PL_multi_close PL_parser->multi_close +# endif #else # ifndef PL_linestr # define PL_linestr PL_Ilinestr @@ -81,344 +159,93 @@ # ifndef PL_oldbufptr # define PL_oldbufptr PL_Ioldbufptr # endif -#endif - -#ifndef I_WORKAROUND_REQUIRE_PROPAGATION -# define I_WORKAROUND_REQUIRE_PROPAGATION !I_HAS_PERL(5, 10, 1) -#endif - -/* ... 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 -# else -# define I_MULTIPLICITY 0 +# ifndef PL_lex_inwhat +# define PL_lex_inwhat PL_Ilex_inwhat # 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)) +# ifndef PL_multi_close +# define PL_multi_close PL_Imulti_close # 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 ------------------------------------------------------------- */ - -/* ... Thread-safe hints ................................................... */ - -#if I_WORKAROUND_REQUIRE_PROPAGATION - -typedef struct { - SV *code; - IV require_tag; -} indirect_hint_t; - -#define I_HINT_STRUCT 1 - -#define I_HINT_CODE(H) ((H)->code) - -#define I_HINT_FREE(H) { \ - indirect_hint_t *h = (H); \ - SvREFCNT_dec(h->code); \ - PerlMemShared_free(h); \ -} - -#else /* I_WORKAROUND_REQUIRE_PROPAGATION */ - -typedef SV indirect_hint_t; - -#define I_HINT_STRUCT 0 - -#define I_HINT_CODE(H) (H) - -#define I_HINT_FREE(H) SvREFCNT_dec(H); - -#endif /* !I_WORKAROUND_REQUIRE_PROPAGATION */ - -#if I_THREADSAFE - -#define PTABLE_NAME ptable_hints -#define PTABLE_VAL_FREE(V) I_HINT_FREE(V) - -#define pPTBL pTHX -#define pPTBL_ pTHX_ -#define aPTBL aTHX -#define aPTBL_ aTHX_ - -#include "ptable.h" - -#define ptable_hints_store(T, K, V) ptable_hints_store(aTHX_ (T), (K), (V)) -#define ptable_hints_free(T) ptable_hints_free(aTHX_ (T)) - -#endif /* I_THREADSAFE */ - -/* Define the op->str ptable here because we need to be able to clean it during - * thread cleanup. */ - -typedef struct { - STRLEN pos; - STRLEN size; - STRLEN len; - char *buf; - line_t line; -} indirect_op_info_t; - -#define PTABLE_NAME ptable -#define PTABLE_VAL_FREE(V) if (V) { Safefree(((indirect_op_info_t *) (V))->buf); Safefree(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)) - -#define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION - -typedef struct { -#if I_THREADSAFE - ptable *tbl; /* It really is a ptable_hints */ - tTHX owner; #endif - ptable *map; -} my_cxt_t; - -START_MY_CXT -#if I_THREADSAFE +/* ... Safe version of call_sv() ........................................... */ -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; +static I32 indirect_call_sv(pTHX_ SV *sv, I32 flags) { +#define indirect_call_sv(S, F) indirect_call_sv(aTHX_ (S), (F)) + I32 ret, cxix; + PERL_CONTEXT saved_cx; + SV *saved_errsv = 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); + if (SvTRUE(ERRSV)) { + if (IN_PERL_COMPILETIME && PL_errors) + sv_catsv(PL_errors, ERRSV); + else + saved_errsv = newSVsv(ERRSV); + SvCUR_set(ERRSV, 0); } - return SvREFCNT_inc(dupsv); -} - -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; - -#if I_HINT_STRUCT - - 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)); + cxix = (cxstack_ix < cxstack_max) ? (cxstack_ix + 1) : Perl_cxinc(aTHX); + /* The last popped context will be reused by call_sv(), but our callers may + * still need its previous value. Back it up so that it isn't clobbered. */ + saved_cx = cxstack[cxix]; + + ret = call_sv(sv, flags | G_EVAL); + + cxstack[cxix] = saved_cx; + + if (SvTRUE(ERRSV)) { + /* Discard the old ERRSV, and reuse the variable to temporarily store the + * new one. */ + if (saved_errsv) + sv_setsv(saved_errsv, ERRSV); + else + saved_errsv = newSVsv(ERRSV); + SvCUR_set(ERRSV, 0); + /* Immediately flush all errors. */ + if (IN_PERL_COMPILETIME) { +#if XSH_HAS_PERL(5, 10, 0) || defined(PL_parser) + if (PL_parser) + ++PL_parser->error_count; +#elif defined(PL_error_count) + ++PL_error_count; +#else + ++PL_Ierror_count; #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); -} - -#include "reap.h" - -STATIC void indirect_thread_cleanup(pTHX_ void *ud) { - dMY_CXT; - - ptable_free(MY_CXT.map); - ptable_hints_free(MY_CXT.tbl); -} - -#endif /* I_THREADSAFE */ - -#if I_WORKAROUND_REQUIRE_PROPAGATION -STATIC IV indirect_require_tag(pTHX) { -#define indirect_require_tag() indirect_require_tag(aTHX) - const CV *cv, *outside; - - cv = PL_compcv; - - 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; - - 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; - - 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; - } + if (PL_errors) { + sv_setsv(ERRSV, PL_errors); + SvCUR_set(PL_errors, 0); } } - - 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; - dMY_CXT; - - if (SvROK(value)) { - value = SvRV(value); - if (SvTYPE(value) >= SVt_PVCV) { - code = value; - SvREFCNT_inc_simple_NN(code); - } + sv_catsv(ERRSV, saved_errsv); + SvREFCNT_dec(saved_errsv); + croak(NULL); + } else if (saved_errsv) { + /* If IN_PERL_COMPILETIME && PL_errors, then the old ERRSV has already been + * added to PL_errors. Otherwise, just restore it to ERRSV, as if no eval + * block has ever been executed. */ + sv_setsv(ERRSV, saved_errsv); + SvREFCNT_dec(saved_errsv); } -#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); -#endif /* I_THREADSAFE */ - - return newSViv(PTR2IV(h)); -} - -STATIC SV *indirect_detag(pTHX_ const SV *hint) { -#define indirect_detag(H) indirect_detag(aTHX_ (H)) - indirect_hint_t *h; - dMY_CXT; - - if (!(hint && SvIOK(hint))) - return NULL; - - h = INT2PTR(indirect_hint_t *, SvIVX(hint)); -#if I_THREADSAFE - h = ptable_fetch(MY_CXT.tbl, h); -#endif /* I_THREADSAFE */ - -#if I_WORKAROUND_REQUIRE_PROPAGATION - if (indirect_require_tag() != h->require_tag) - return NULL; -#endif /* I_WORKAROUND_REQUIRE_PROPAGATION */ - - return I_HINT_CODE(h); + return ret; } -STATIC U32 indirect_hash = 0; - -STATIC SV *indirect_hint(pTHX) { -#define indirect_hint() indirect_hint(aTHX) - SV *hint; - - if (IN_PERL_RUNTIME) - return NULL; - -#if 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__, - indirect_hash); - if (!val) - return 0; - hint = *val; - } -#endif - return indirect_detag(hint); -} +/* --- Check functions ----------------------------------------------------- */ -/* ... op -> source position ............................................... */ +/* ... op => source position map, continued ................................ */ -STATIC void indirect_map_store(pTHX_ const OP *o, STRLEN pos, SV *sv, line_t line) { +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; + dXSH_CXT; + + /* No need to check for XSH_CXT.map != NULL because this code path is always + * guarded by indirect_hint(). */ - if (!(oi = ptable_fetch(MY_CXT.map, o))) { - Newx(oi, 1, indirect_op_info_t); - ptable_store(MY_CXT.map, o, oi); + if (!(oi = ptable_fetch(XSH_CXT.map, o))) { + XSH_LOCAL_ALLOC(oi, 1, indirect_op_info_t); + ptable_store(XSH_CXT.map, o, oi); oi->buf = NULL; oi->size = 0; } @@ -431,75 +258,113 @@ STATIC void indirect_map_store(pTHX_ const OP *o, STRLEN pos, SV *sv, line_t lin } if (len > oi->size) { - Safefree(oi->buf); - Newx(oi->buf, len, char); + XSH_LOCAL_REALLOC(oi->buf, oi->size, len, char); oi->size = len; } - Copy(s, oi->buf, len, char); + if (oi->buf) + Copy(s, oi->buf, len, char); oi->len = len; oi->pos = pos; oi->line = line; } -STATIC const indirect_op_info_t *indirect_map_fetch(pTHX_ const OP *o) { +static const indirect_op_info_t *indirect_map_fetch(pTHX_ const OP *o) { #define indirect_map_fetch(O) indirect_map_fetch(aTHX_ (O)) - dMY_CXT; + dXSH_CXT; - return ptable_fetch(MY_CXT.map, o); + /* No need to check for XSH_CXT.map != NULL because this code path is always + * guarded by indirect_hint(). */ + + return ptable_fetch(XSH_CXT.map, o); } -STATIC void indirect_map_delete(pTHX_ const OP *o) { +static void indirect_map_delete(pTHX_ const OP *o) { #define indirect_map_delete(O) indirect_map_delete(aTHX_ (O)) - dMY_CXT; + dXSH_CXT; - ptable_store(MY_CXT.map, o, NULL); + if (xsh_is_loaded(&XSH_CXT) && XSH_CXT.map) + ptable_delete(XSH_CXT.map, 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 = NULL, *r = SvPV_const(sv, len); - - if (len >= 1 && *r == '$') { - ++r; - --len; - s = strchr(s, '$'); - if (!s) +/* ... Heuristics for finding a string in the source buffer ................ */ + +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; } - if (!p) - return 0; - *pos = p - SvPVX_const(PL_linestr); + *name_pos = p - line; return 1; } /* ... ck_const ............................................................ */ -STATIC OP *(*indirect_old_ck_const)(pTHX_ OP *) = 0; +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); +static OP *indirect_ck_const(pTHX_ OP *o) { + o = indirect_old_ck_const(aTHX_ o); if (indirect_hint()) { SV *sv = cSVOPo_sv; if (SvPOK(sv) && (SvTYPE(sv) >= SVt_PV)) { STRLEN pos; + const char *bufptr; + + bufptr = PL_multi_close == '<' ? PL_bufptr : PL_oldbufptr; + + if (indirect_find(sv, bufptr, &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; + } + } - if (indirect_find(sv, PL_oldbufptr, &pos)) { indirect_map_store(o, pos, sv, CopLINE(&PL_compiling)); return o; } @@ -512,9 +377,9 @@ STATIC OP *indirect_ck_const(pTHX_ OP *o) { /* ... ck_rv2sv ............................................................ */ -STATIC OP *(*indirect_old_ck_rv2sv)(pTHX_ OP *) = 0; +static OP *(*indirect_old_ck_rv2sv)(pTHX_ OP *) = 0; -STATIC OP *indirect_ck_rv2sv(pTHX_ OP *o) { +static OP *indirect_ck_rv2sv(pTHX_ OP *o) { if (indirect_hint()) { OP *op = cUNOPo->op_first; SV *sv; @@ -564,14 +429,14 @@ STATIC OP *indirect_ck_rv2sv(pTHX_ OP *o) { goto done; } - o = CALL_FPTR(indirect_old_ck_rv2sv)(aTHX_ o); + 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; @@ -579,10 +444,10 @@ done: /* ... ck_padany ........................................................... */ -STATIC OP *(*indirect_old_ck_padany)(pTHX_ OP *) = 0; +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); +static OP *indirect_ck_padany(pTHX_ OP *o) { + o = indirect_old_ck_padany(aTHX_ o); if (indirect_hint()) { SV *sv; @@ -606,17 +471,17 @@ STATIC OP *indirect_ck_padany(pTHX_ OP *o) { /* ... ck_scope ............................................................ */ -STATIC OP *(*indirect_old_ck_scope) (pTHX_ OP *) = 0; -STATIC OP *(*indirect_old_ck_lineseq)(pTHX_ OP *) = 0; +static OP *(*indirect_old_ck_scope) (pTHX_ OP *) = 0; +static OP *(*indirect_old_ck_lineseq)(pTHX_ OP *) = 0; -STATIC OP *indirect_ck_scope(pTHX_ OP *o) { +static OP *indirect_ck_scope(pTHX_ OP *o) { OP *(*old_ck)(pTHX_ OP *) = 0; switch (o->op_type) { 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 - SvPVX_const(PL_linestr), @@ -633,9 +498,9 @@ STATIC OP *indirect_ck_scope(pTHX_ OP *o) { /* ... ck_method ........................................................... */ -STATIC OP *(*indirect_old_ck_method)(pTHX_ OP *) = 0; +static OP *(*indirect_old_ck_method)(pTHX_ OP *) = 0; -STATIC OP *indirect_ck_method(pTHX_ OP *o) { +static OP *indirect_ck_method(pTHX_ OP *o) { if (indirect_hint()) { OP *op = cUNOPo->op_first; @@ -656,7 +521,7 @@ STATIC OP *indirect_ck_method(pTHX_ OP *o) { * expression. */ line = oi->line; - o = CALL_FPTR(indirect_old_ck_method)(aTHX_ o); + o = indirect_old_ck_method(aTHX_ o); /* o may now be a method_named */ indirect_map_store(o, pos, sv, line); @@ -665,7 +530,7 @@ STATIC OP *indirect_ck_method(pTHX_ OP *o) { } done: - o = CALL_FPTR(indirect_old_ck_method)(aTHX_ o); + o = indirect_old_ck_method(aTHX_ o); indirect_map_delete(o); return o; @@ -676,9 +541,9 @@ done: /* "use foo/no foo" compiles its call to import/unimport directly to a * method_named op. */ -STATIC OP *(*indirect_old_ck_method_named)(pTHX_ OP *) = 0; +static OP *(*indirect_old_ck_method_named)(pTHX_ OP *) = 0; -STATIC OP *indirect_ck_method_named(pTHX_ OP *o) { +static OP *indirect_ck_method_named(pTHX_ OP *o) { if (indirect_hint()) { STRLEN pos; line_t line; @@ -693,14 +558,14 @@ STATIC OP *indirect_ck_method_named(pTHX_ OP *o) { goto done; line = CopLINE(&PL_compiling); - o = CALL_FPTR(indirect_old_ck_method_named)(aTHX_ o); + o = indirect_old_ck_method_named(aTHX_ o); indirect_map_store(o, pos, sv, line); return o; } done: - o = CALL_FPTR(indirect_old_ck_method_named)(aTHX_ o); + o = indirect_old_ck_method_named(aTHX_ o); indirect_map_delete(o); return o; @@ -708,22 +573,12 @@ done: /* ... ck_entersub ......................................................... */ -STATIC int indirect_is_indirect(const indirect_op_info_t *moi, const indirect_op_info_t *ooi) { - if (moi->pos > ooi->pos) - return 0; - - if (moi->pos == ooi->pos) - return moi->len == ooi->len && !memcmp(moi->buf, ooi->buf, moi->len); - - return 1; -} - -STATIC OP *(*indirect_old_ck_entersub)(pTHX_ OP *) = 0; +static OP *(*indirect_old_ck_entersub)(pTHX_ OP *) = 0; -STATIC OP *indirect_ck_entersub(pTHX_ OP *o) { +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; @@ -737,7 +592,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 = OpSIBLING(oop); mop = lop->op_last; if (!oop) @@ -767,7 +622,11 @@ STATIC OP *indirect_ck_entersub(pTHX_ OP *o) { 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; @@ -788,7 +647,7 @@ STATIC OP *indirect_ck_entersub(pTHX_ OP *o) { mPUSHu(moi->line); PUTBACK; - call_sv(code, G_VOID); + indirect_call_sv(code, G_VOID); PUTBACK; @@ -801,87 +660,61 @@ done: return o; } -STATIC U32 indirect_initialized = 0; +/* --- Module setup/teardown ----------------------------------------------- */ -STATIC void indirect_teardown(pTHX_ void *root) { - dMY_CXT; +static void xsh_user_global_setup(pTHX) { + xsh_ck_replace(OP_CONST, indirect_ck_const, &indirect_old_ck_const); + xsh_ck_replace(OP_RV2SV, indirect_ck_rv2sv, &indirect_old_ck_rv2sv); + xsh_ck_replace(OP_PADANY, indirect_ck_padany, &indirect_old_ck_padany); + xsh_ck_replace(OP_SCOPE, indirect_ck_scope, &indirect_old_ck_scope); + xsh_ck_replace(OP_LINESEQ, indirect_ck_scope, &indirect_old_ck_lineseq); - if (!indirect_initialized) - return; + xsh_ck_replace(OP_METHOD, indirect_ck_method, + &indirect_old_ck_method); + xsh_ck_replace(OP_METHOD_NAMED, indirect_ck_method_named, + &indirect_old_ck_method_named); + xsh_ck_replace(OP_ENTERSUB, indirect_ck_entersub, + &indirect_old_ck_entersub); -#if I_MULTIPLICITY - if (aTHX != root) - return; -#endif + return; +} - ptable_free(MY_CXT.map); -#if I_THREADSAFE - ptable_hints_free(MY_CXT.tbl); -#endif +static void xsh_user_local_setup(pTHX_ xsh_user_cxt_t *cxt) { + HV *stash; - 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_METHOD_NAMED] = MEMBER_TO_FPTR(indirect_old_ck_method_named); - indirect_old_ck_method_named = 0; - PL_check[OP_ENTERSUB] = MEMBER_TO_FPTR(indirect_old_ck_entersub); - indirect_old_ck_entersub = 0; - - indirect_initialized = 0; -} + stash = gv_stashpvn(XSH_PACKAGE, XSH_PACKAGE_LEN, 1); + newCONSTSUB(stash, "I_THREADSAFE", newSVuv(XSH_THREADSAFE)); + newCONSTSUB(stash, "I_FORKSAFE", newSVuv(XSH_FORKSAFE)); -STATIC void indirect_setup(pTHX) { -#define indirect_setup() indirect_setup(aTHX) - if (indirect_initialized) - return; + cxt->map = ptable_new(32); + cxt->global_code = NULL; - { - MY_CXT_INIT; -#if I_THREADSAFE - MY_CXT.tbl = ptable_new(); - MY_CXT.owner = aTHX; -#endif - MY_CXT.map = ptable_new(); - } + return; +} - 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_method_named = PL_check[OP_METHOD_NAMED]; - PL_check[OP_METHOD_NAMED] = MEMBER_TO_FPTR(indirect_ck_method_named); - indirect_old_ck_entersub = PL_check[OP_ENTERSUB]; - PL_check[OP_ENTERSUB] = MEMBER_TO_FPTR(indirect_ck_entersub); - -#if I_MULTIPLICITY - call_atexit(indirect_teardown, aTHX); -#else - call_atexit(indirect_teardown, NULL); -#endif +static void xsh_user_local_teardown(pTHX_ xsh_user_cxt_t *cxt) { + SvREFCNT_dec(cxt->global_code); + cxt->global_code = NULL; + + ptable_free(cxt->map); + cxt->map = NULL; - indirect_initialized = 1; + return; } -STATIC U32 indirect_booted = 0; +static void xsh_user_global_teardown(pTHX) { + xsh_ck_restore(OP_CONST, &indirect_old_ck_const); + xsh_ck_restore(OP_RV2SV, &indirect_old_ck_rv2sv); + xsh_ck_restore(OP_PADANY, &indirect_old_ck_padany); + xsh_ck_restore(OP_SCOPE, &indirect_old_ck_scope); + xsh_ck_restore(OP_LINESEQ, &indirect_old_ck_lineseq); + + xsh_ck_restore(OP_METHOD, &indirect_old_ck_method); + xsh_ck_restore(OP_METHOD_NAMED, &indirect_old_ck_method_named); + xsh_ck_restore(OP_ENTERSUB, &indirect_old_ck_entersub); + + return; +} /* --- XS ------------------------------------------------------------------ */ @@ -891,49 +724,43 @@ PROTOTYPES: ENABLE BOOT: { - if (!indirect_booted++) { - HV *stash; - - PERL_HASH(indirect_hash, __PACKAGE__, __PACKAGE_LEN__); - - stash = gv_stashpvn(__PACKAGE__, __PACKAGE_LEN__, 1); - newCONSTSUB(stash, "I_THREADSAFE", newSVuv(I_THREADSAFE)); - newCONSTSUB(stash, "I_FORKSAFE", newSVuv(I_FORKSAFE)); - } - - indirect_setup(); + xsh_setup(); } -#if I_THREADSAFE +#if XSH_THREADSAFE void CLONE(...) PROTOTYPE: DISABLE -PREINIT: - ptable *t; 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); - } - { - MY_CXT_CLONE; - MY_CXT.map = ptable_new(); - MY_CXT.tbl = t; - MY_CXT.owner = aTHX; - } - reap(3, indirect_thread_cleanup, NULL); + xsh_clone(); XSRETURN(0); -#endif +#endif /* XSH_THREADSAFE */ SV * -_tag(SV *value) +_tag(SV *code) PROTOTYPE: $ CODE: - RETVAL = indirect_tag(value); + if (!SvOK(code)) + code = NULL; + else if (SvROK(code)) + code = SvRV(code); + RETVAL = xsh_hints_tag(code); OUTPUT: RETVAL + +void +_global(SV *code) +PROTOTYPE: $ +PPCODE: + if (!SvOK(code)) + code = NULL; + else if (SvROK(code)) + code = SvRV(code); + { + dXSH_CXT; + SvREFCNT_dec(XSH_CXT.global_code); + XSH_CXT.global_code = SvREFCNT_inc(code); + } + XSRETURN(0);