X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=Op.xs;h=f101fa7509fb1d866cac0d72b6c72a5a598996b3;hb=302bf09fbd4b673e199bdd22b330ebbdbec4e1fe;hp=ecdac3a3cbfe578bfd3fc47bab22f6e25c41499a;hpb=c987524f0641ca6a25d5e3072c9d1a2ecef2f57c;p=perl%2Fmodules%2FSub-Op.git diff --git a/Op.xs b/Op.xs index ecdac3a..f101fa7 100644 --- a/Op.xs +++ b/Op.xs @@ -114,18 +114,24 @@ typedef struct { #include "sub_op.h" void sub_op_init(sub_op_config_t *c) { - c->name = NULL; - c->namelen = 0; - c->pp = 0; - c->check = 0; - c->ud = NULL; + c->name = NULL; + c->namelen = 0; + c->proto = NULL; + c->protolen = 0; + c->pp = 0; + c->check = 0; + c->ref = 0; + c->ud = NULL; return; } -void sub_op_register(pTHX_ const sub_op_config_t *c) { +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(c->name, c->namelen), 0); @@ -134,28 +140,42 @@ void sub_op_register(pTHX_ const sub_op_config_t *c) { PL_custom_op_descs = newHV(); (void) hv_store_ent(PL_custom_op_descs, key, newSVpv(c->name, c->namelen), 0); - if (c->check) { - SV *check = newSViv(PTR2IV(c->check)); - sv_magicext(key, check, PERL_MAGIC_ext, NULL, c->ud, 0); - SvREFCNT_dec(check); - } + SvREFCNT_dec(key); { dMY_CXT; - (void) hv_store(MY_CXT.map, c->name, c->namelen, key, 0); + (void) hv_store(MY_CXT.map, c->name, c->namelen, newSViv(PTR2IV(c)), 0); } } sub_op_config_t *sub_op_dup(pTHX_ const sub_op_config_t *orig) { + STRLEN len; 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); + len = orig->namelen; + if (orig->name) { + dupe->name = PerlMemShared_malloc(len + 1); + Copy(orig->name, dupe->name, len, char); + ((char *) dupe->name)[len] = '\0'; + } else { + dupe->name = NULL; + } + dupe->namelen = len; + + len = orig->protolen; + if (orig->proto) { + dupe->proto = PerlMemShared_malloc(len + 1); + Copy(orig->proto, dupe->proto, len, char); + ((char *) dupe->proto)[len] = '\0'; + } else { + dupe->proto = NULL; + } + dupe->protolen = len; - dupe->pp = orig->pp; - dupe->check = orig->check; - dupe->ud = orig->ud; + dupe->pp = orig->pp; + dupe->check = orig->check; + dupe->ref = orig->ref; + dupe->ud = orig->ud; return dupe; } @@ -191,13 +211,55 @@ STATIC IV so_hint(pTHX) { return (SvOK(hint) && SvIOK(hint)) ? SvIVX(hint) : 0; } +STATIC OP *so_find_gvop(OP *o, OP **last_arg_p, OP **rv2cv_p) { + OP *ex_list, *last_arg, *rv2cv, *gvop; + + ex_list = cUNOPo->op_first; + /* pushmark when a method call */ + if (!ex_list || ex_list->op_type != OP_NULL) + goto skip; + + rv2cv = cUNOPx(ex_list)->op_first; + if (!rv2cv) + goto skip; + + while (1) { + OP *next = rv2cv->op_sibling; + if (!next) + break; + last_arg = rv2cv; + rv2cv = next; + } + + if (!(rv2cv->op_flags & OPf_KIDS)) + goto skip; + + gvop = cUNOPx(rv2cv)->op_first; + + if (gvop && gvop->op_type == OP_GV) + goto done; + +skip: + last_arg = NULL; + rv2cv = NULL; + gvop = NULL; + +done: + if (last_arg_p) + *last_arg_p = last_arg; + if (rv2cv_p) + *rv2cv_p = rv2cv; + + return gvop; +} + STATIC OP *(*so_old_ck_entersub)(pTHX_ OP *) = 0; STATIC OP *so_ck_entersub(pTHX_ OP *o) { o = CALL_FPTR(so_old_ck_entersub)(aTHX_ o); if (so_hint()) { - OP *ex_list, *rv2cv, *gvop, *last_arg = NULL; + OP *ex_list, *last_arg, *rv2cv, *gvop; GV *gv; if (o->op_type != OP_ENTERSUB) @@ -205,46 +267,25 @@ STATIC OP *so_ck_entersub(pTHX_ OP *o) { if (o->op_private & OPpENTERSUB_AMPER) /* hopefully \&foo */ goto skip; - ex_list = cUNOPo->op_first; - /* pushmark when a method call */ - if (!ex_list || ex_list->op_type != OP_NULL) - goto skip; - - rv2cv = cUNOPx(ex_list)->op_first; - if (!rv2cv) - goto skip; - - while (1) { - OP *next = rv2cv->op_sibling; - if (!next) - break; - last_arg = rv2cv; - rv2cv = next; - } - - if (!(rv2cv->op_flags & OPf_KIDS)) - goto skip; - - gvop = cUNOPx(rv2cv)->op_first; - if (!gvop || gvop->op_type != OP_GV) + gvop = so_find_gvop(o, &last_arg, &rv2cv); + if (!gvop) goto skip; gv = cGVOPx_gv(gvop); { - 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); @@ -252,20 +293,15 @@ STATIC OP *so_ck_entersub(pTHX_ OP *o) { } 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); - } - } + if (c->check) + o = CALL_FPTR(c->check)(aTHX_ o, c->ud); { so_op_name_t *on = PerlMemShared_malloc(sizeof(*on) + len); @@ -287,6 +323,72 @@ skip: return o; } +STATIC OP *(*so_old_ck_refgen)(pTHX_ OP *) = 0; + +STATIC OP *so_ck_refgen(pTHX_ OP *o) { + o = CALL_FPTR(so_old_ck_refgen)(aTHX_ o); + + if (so_hint()) { + OP *kid = o; + OP *prev = NULL; + OP *parent = NULL; + + while (kid->op_flags & OPf_KIDS) { + parent = kid; + kid = cUNOPx(kid)->op_first; + } + + if (!parent) + goto skip; + + for (kid; kid; prev = kid, kid = kid->op_sibling) { + OP *gvop; + GV *gv; + const sub_op_config_t *c; + + if (kid->op_type != OP_RV2CV) + continue; + + gvop = so_find_gvop(kid, NULL, NULL); + if (!gvop) + continue; + + gv = cGVOPx_gv(gvop); + + { + SV **svp; + const char *name = GvNAME(gv); + I32 len = GvNAMELEN(gv); + dMY_CXT; + + svp = hv_fetch(MY_CXT.map, name, len, 0); + if (!svp) + continue; + + c = INT2PTR(const sub_op_config_t *, SvIVX(*svp)); + } + + if (c->ref) { + OP *new_kid = CALL_FPTR(c->ref)(aTHX_ kid, c->ud); + + if (new_kid != kid) { + new_kid->op_sibling = kid->op_sibling; + new_kid->op_next = new_kid; + if (prev) + prev->op_sibling = new_kid; + else + cUNOPx(parent)->op_first = new_kid; + op_null(kid); + kid = new_kid; + } + } + } + } + +skip: + return o; +} + STATIC OP *(*so_old_ck_gelem)(pTHX_ OP *) = 0; STATIC OP *so_ck_gelem(pTHX_ OP *o) { @@ -345,6 +447,8 @@ BOOT: so_old_ck_entersub = PL_check[OP_ENTERSUB]; PL_check[OP_ENTERSUB] = so_ck_entersub; + so_old_ck_refgen = PL_check[OP_REFGEN]; + PL_check[OP_REFGEN] = so_ck_refgen; so_old_ck_gelem = PL_check[OP_GELEM]; PL_check[OP_GELEM] = so_ck_gelem; } @@ -424,3 +528,20 @@ PPCODE: XSRETURN_UNDEF; ST(0) = sv_2mortal(newSVuv(CvCONST(sv))); XSRETURN(1); + +SV * +_get_prototype(SV *name) +PROTOTYPE: $ +PREINIT: + HE *he; + const sub_op_config_t *c; +PPCODE: + dMY_CXT; + he = hv_fetch_ent(MY_CXT.map, name, 0, 0); + if (!he) + XSRETURN_UNDEF; + c = INT2PTR(const sub_op_config_t *, SvIVX(HeVAL(he))); + if (!c->proto) + XSRETURN_UNDEF; + ST(0) = sv_2mortal(newSVpvn(c->proto, c->protolen)); + XSRETURN(1);