X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FSub-Op.git;a=blobdiff_plain;f=Op.xs;h=17fa468fc11fad06ff19b269e215cdb9acdf4541;hp=8b761adfab1044a113921842b16003c5e56c0b00;hb=159088ccddecdea45fdae8093319b41c097adc86;hpb=cf6a8cf942e28d57dc90e19e87237c87a3219cea diff --git a/Op.xs b/Op.xs index 8b761ad..17fa468 100644 --- a/Op.xs +++ b/Op.xs @@ -98,79 +98,78 @@ STATIC SV *so_clone(pTHX_ SV *sv, tTHX owner) { /* PerlMemShared_free() needs the [ap]PTBLMS_? default values */ #define ptable_store(T, K, V) ptable_store(aPTBLMS_ (T), (K), (V)) -STATIC ptable *sub_op_name = NULL; +STATIC ptable *so_op_name = NULL; #ifdef USE_ITHREADS -STATIC perl_mutex sub_op_name_mutex; +STATIC perl_mutex so_op_name_mutex; #endif typedef struct { STRLEN len; char buf; -} sub_op_name_t; +} so_op_name_t; /* --- Public API ---------------------------------------------------------- */ #include "sub_op.h" -void sub_op_register(pTHX_ const sub_op_keyword *k) { - SV *key = newSViv(PTR2IV(k->pp)); +void sub_op_init(sub_op_config_t *c) { + c->name = NULL; + c->namelen = 0; + c->pp = 0; + c->check = 0; + c->ud = NULL; + + return; +} + +void sub_op_register(pTHX_ const sub_op_config_t *c, U32 flags) { + SV *key = newSViv(PTR2IV(c->pp)); + + if (!(flags & SUB_OP_REGISTER_STEAL)) + c = sub_op_dup(aTHX_ c); if (!PL_custom_op_names) PL_custom_op_names = newHV(); - (void) hv_store_ent(PL_custom_op_names, key, newSVpv(k->name, k->len), 0); + (void) hv_store_ent(PL_custom_op_names, key, newSVpv(c->name, c->namelen), 0); if (!PL_custom_op_descs) PL_custom_op_descs = newHV(); - (void) hv_store_ent(PL_custom_op_descs, key, newSVpv(k->name, k->len), 0); + (void) hv_store_ent(PL_custom_op_descs, key, newSVpv(c->name, c->namelen), 0); - if (k->check) { - SV *check = newSViv(PTR2IV(k->check)); - sv_magicext(key, check, PERL_MAGIC_ext, NULL, k->ud, 0); - SvREFCNT_dec(check); - } + SvREFCNT_dec(key); { dMY_CXT; - (void) hv_store(MY_CXT.map, k->name, k->len, key, 0); + (void) hv_store(MY_CXT.map, c->name, c->namelen, newSViv(PTR2IV(c)), 0); } } -/* --- Private helpers ----------------------------------------------------- */ +sub_op_config_t *sub_op_dup(pTHX_ const sub_op_config_t *orig) { + sub_op_config_t *dupe = PerlMemShared_malloc(sizeof *dupe); + + dupe->namelen = orig->namelen; + dupe->name = PerlMemShared_malloc(dupe->namelen); + Copy(orig->name, dupe->name, dupe->namelen, char); -#define SO_LINKLIST(O) ((O)->op_next ? (O)->op_next : sub_op_linklist(O)) - -STATIC OP *sub_op_linklist(pTHX_ OP *o) { -#define sub_op_linklist(O) sub_op_linklist(aTHX_ (O)) - OP *first; - - if (o->op_next) - return o->op_next; - - /* establish postfix order */ - first = cUNOPo->op_first; - if (first) { - register OP *kid; - o->op_next = SO_LINKLIST(first); - kid = first; - for (;;) { - if (kid->op_sibling) { - kid->op_next = SO_LINKLIST(kid->op_sibling); - kid = kid->op_sibling; - } else { - kid->op_next = o; - break; - } - } - } - else - o->op_next = o; - - return o->op_next; + dupe->pp = orig->pp; + dupe->check = orig->check; + dupe->ud = orig->ud; + + return dupe; +} + +void sub_op_free(pTHX_ sub_op_config_t *c) { + PerlMemShared_free((char *) c->name); + PerlMemShared_free(c); + + return; } -STATIC IV sub_op_hint(pTHX) { -#define sub_op_hint() sub_op_hint(aTHX) +/* --- Private helpers ----------------------------------------------------- */ + +STATIC IV so_hint(pTHX) { +#define so_hint() so_hint(aTHX) SV *hint; #if SO_HAS_PERL(5, 9, 5) @@ -191,12 +190,12 @@ STATIC IV sub_op_hint(pTHX) { return (SvOK(hint) && SvIOK(hint)) ? SvIVX(hint) : 0; } -STATIC OP *(*sub_op_old_ck_entersub)(pTHX_ OP *) = 0; +STATIC OP *(*so_old_ck_entersub)(pTHX_ OP *) = 0; -STATIC OP *sub_op_ck_entersub(pTHX_ OP *o) { - o = CALL_FPTR(sub_op_old_ck_entersub)(aTHX_ o); +STATIC OP *so_ck_entersub(pTHX_ OP *o) { + o = CALL_FPTR(so_old_ck_entersub)(aTHX_ o); - if (sub_op_hint()) { + if (so_hint()) { OP *ex_list, *rv2cv, *gvop, *last_arg = NULL; GV *gv; @@ -232,58 +231,46 @@ STATIC OP *sub_op_ck_entersub(pTHX_ OP *o) { gv = cGVOPx_gv(gvop); { - HV *stash = GvSTASH(gv); - SV *pp_sv, **svp; - CV *cv = NULL; + SV **svp; + CV *cv = NULL; const char *name = GvNAME(gv); I32 len = GvNAMELEN(gv); + const sub_op_config_t *c; dMY_CXT; svp = hv_fetch(MY_CXT.map, name, len, 0); if (!svp) goto skip; - pp_sv = *svp; - if (!pp_sv || !SvOK(pp_sv)) - goto skip; + c = INT2PTR(const sub_op_config_t *, SvIVX(*svp)); if (gv && SvTYPE(gv) >= SVt_PVGV && (cv = GvCV(gv)) == MY_CXT.placeholder) { SvREFCNT_dec(cv); GvCV(gv) = NULL; - if (!GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIO(gv) && !GvFORM(gv)) { - (void) hv_delete(stash, name, len, G_DISCARD); - } } o->op_type = OP_CUSTOM; - o->op_ppaddr = INT2PTR(Perl_ppaddr_t, SvIVX(pp_sv)); + o->op_ppaddr = c->pp; if (last_arg) last_arg->op_sibling = NULL; op_free(rv2cv); - { - MAGIC *mg = mg_find(pp_sv, PERL_MAGIC_ext); - if (mg) { - sub_op_check_t check = INT2PTR(sub_op_check_t, SvIVX(mg->mg_obj)); - o = CALL_FPTR(check)(aTHX_ o, mg->mg_ptr); - } - } - - sub_op_linklist(o); + if (c->check) + o = CALL_FPTR(c->check)(aTHX_ o, c->ud); { - sub_op_name_t *on = PerlMemShared_malloc(sizeof(*on) + len); + so_op_name_t *on = PerlMemShared_malloc(sizeof(*on) + len); Copy(name, &on->buf, len, char); (&on->buf)[len] = '\0'; on->len = len; #ifdef USE_ITHREADS - MUTEX_LOCK(&sub_op_name_mutex); + MUTEX_LOCK(&so_op_name_mutex); #endif /* USE_ITHREADS */ - ptable_store(sub_op_name, o, on); + ptable_store(so_op_name, o, on); #ifdef USE_ITHREADS - MUTEX_UNLOCK(&sub_op_name_mutex); + MUTEX_UNLOCK(&so_op_name_mutex); #endif /* USE_ITHREADS */ } } @@ -293,12 +280,12 @@ skip: return o; } -STATIC OP *(*sub_op_old_ck_gelem)(pTHX_ OP *) = 0; +STATIC OP *(*so_old_ck_gelem)(pTHX_ OP *) = 0; -STATIC OP *sub_op_ck_gelem(pTHX_ OP *o) { - o = CALL_FPTR(sub_op_old_ck_entersub)(aTHX_ o); +STATIC OP *so_ck_gelem(pTHX_ OP *o) { + o = CALL_FPTR(so_old_ck_entersub)(aTHX_ o); - if (sub_op_hint()) { + if (so_hint()) { OP *rv2gv, *gvop; GV *gv; @@ -321,9 +308,6 @@ STATIC OP *sub_op_ck_gelem(pTHX_ OP *o) { if (gv && SvTYPE(gv) >= SVt_PVGV && (cv = GvCV(gv)) == MY_CXT.placeholder) { SvREFCNT_dec(cv); GvCV(gv) = NULL; - if (!GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIO(gv) && !GvFORM(gv)) { - (void)hv_delete(GvSTASH(gv), GvNAME_get(gv), GvNAMELEN_get(gv), G_DISCARD); - } } } } @@ -340,9 +324,9 @@ PROTOTYPES: ENABLE BOOT: { - sub_op_name = ptable_new(); + so_op_name = ptable_new(); #ifdef USE_ITHREADS - MUTEX_INIT(&sub_op_name_mutex); + MUTEX_INIT(&so_op_name_mutex); #endif MY_CXT_INIT; @@ -352,10 +336,10 @@ BOOT: MY_CXT.owner = aTHX; #endif /* SO_THREADSAFE */ - sub_op_old_ck_entersub = PL_check[OP_ENTERSUB]; - PL_check[OP_ENTERSUB] = sub_op_ck_entersub; - sub_op_old_ck_gelem = PL_check[OP_GELEM]; - PL_check[OP_GELEM] = sub_op_ck_gelem; + so_old_ck_entersub = PL_check[OP_ENTERSUB]; + PL_check[OP_ENTERSUB] = so_ck_entersub; + so_old_ck_gelem = PL_check[OP_GELEM]; + PL_check[OP_GELEM] = so_ck_gelem; } #if SO_THREADSAFE @@ -367,7 +351,7 @@ PREINIT: HV *map; CV *placeholder; tTHX owner; -CODE: +PPCODE: { dMY_CXT; owner = MY_CXT.owner; @@ -380,6 +364,7 @@ CODE: MY_CXT.placeholder = placeholder; MY_CXT.owner = aTHX; } + XSRETURN(0); #endif /* SO_THREADSAFE */ @@ -402,7 +387,7 @@ _custom_name(SV *op) PROTOTYPE: $ PREINIT: OP *o; - sub_op_name_t *on; + so_op_name_t *on; PPCODE: if (!SvROK(op)) XSRETURN_UNDEF; @@ -410,13 +395,25 @@ PPCODE: if (!o || o->op_type != OP_CUSTOM) XSRETURN_UNDEF; #ifdef USE_ITHREADS - MUTEX_LOCK(&sub_op_name_mutex); + MUTEX_LOCK(&so_op_name_mutex); #endif /* USE_ITHREADS */ - on = ptable_fetch(sub_op_name, o); + on = ptable_fetch(so_op_name, o); #ifdef USE_ITHREADS - MUTEX_UNLOCK(&sub_op_name_mutex); + MUTEX_UNLOCK(&so_op_name_mutex); #endif /* USE_ITHREADS */ if (!on) XSRETURN_UNDEF; ST(0) = sv_2mortal(newSVpvn(&on->buf, on->len)); XSRETURN(1); + +void +_constant_sub(SV *sv) +PROTOTYPE: $ +PPCODE: + if (!SvROK(sv)) + XSRETURN_UNDEF; + sv = SvRV(sv); + if (SvTYPE(sv) < SVt_PVCV) + XSRETURN_UNDEF; + ST(0) = sv_2mortal(newSVuv(CvCONST(sv))); + XSRETURN(1);