#define SO_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
+#ifndef GvCV_set
+# define GvCV_set(G, C) (GvCV(G) = (C))
+#endif
+
/* ... Thread safety and multiplicity ...................................... */
#ifndef SO_MULTIPLICITY
# define MY_CXT_CLONE NOOP
#endif
+#if defined(OP_CHECK_MUTEX_LOCK) && defined(OP_CHECK_MUTEX_UNLOCK)
+# define SO_CHECK_MUTEX_LOCK OP_CHECK_MUTEX_LOCK
+# define SO_CHECK_MUTEX_UNLOCK OP_CHECK_MUTEX_UNLOCK
+#else
+# define SO_CHECK_MUTEX_LOCK OP_REFCNT_LOCK
+# define SO_CHECK_MUTEX_UNLOCK OP_REFCNT_UNLOCK
+#endif
+
+typedef OP *(*so_ck_t)(pTHX_ OP *);
+
+#ifdef wrap_op_checker
+
+# define so_ck_replace(T, NC, OCP) wrap_op_checker((T), (NC), (OCP))
+
+#else
+
+STATIC void so_ck_replace(pTHX_ OPCODE type, so_ck_t new_ck, so_ck_t *old_ck_p){
+#define so_ck_replace(T, NC, OCP) so_ck_replace(aTHX_ (T), (NC), (OCP))
+ SO_CHECK_MUTEX_LOCK;
+ if (!*old_ck_p) {
+ *old_ck_p = PL_check[type];
+ PL_check[type] = new_ck;
+ }
+ SO_CHECK_MUTEX_UNLOCK;
+}
+
+#endif
+
+STATIC void so_ck_restore(pTHX_ OPCODE type, so_ck_t *old_ck_p) {
+#define so_ck_restore(T, OCP) so_ck_restore(aTHX_ (T), (OCP))
+ SO_CHECK_MUTEX_LOCK;
+ if (*old_ck_p) {
+ PL_check[type] = *old_ck_p;
+ *old_ck_p = 0;
+ }
+ SO_CHECK_MUTEX_UNLOCK;
+}
+
/* --- Global data --------------------------------------------------------- */
#define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
typedef struct {
HV *map;
- AV *next_pkg;
- AV *next_name;
CV *placeholder;
#if SO_THREADSAFE
tTHX owner;
#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->proto = NULL;
+ c->protolen = 0;
+ c->call = 0;
+ c->ref = 0;
+ c->ud = NULL;
- 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);
+ return;
+}
- 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 sub_op_register(pTHX_ const sub_op_config_t *c, U32 flags) {
+ dMY_CXT;
- if (k->check) {
- SV *check = newSViv(PTR2IV(k->check));
- sv_magicext(key, check, PERL_MAGIC_ext, NULL, k->ud, 0);
- SvREFCNT_dec(check);
- }
+ if (!(flags & SUB_OP_REGISTER_STEAL))
+ c = sub_op_dup(aTHX_ c);
- {
- 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 ----------------------------------------------------- */
+STATIC const char *so_strndup(pTHX_ const char *s, STRLEN len) {
+#define so_strndup(S, L) so_strndup(aTHX_ (S), (L))
+ const char *d;
-#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;
+ if (!s)
+ return NULL;
- return o->op_next;
+ d = PerlMemShared_malloc(len + 1);
+ Copy(s, d, len, char);
+ ((char *) d)[len] = '\0';
+
+ return d;
}
-STATIC IV sub_op_hint(pTHX) {
-#define sub_op_hint() sub_op_hint(aTHX)
+sub_op_config_t *sub_op_dup(pTHX_ const sub_op_config_t *orig) {
+ sub_op_config_t *dupe = PerlMemShared_malloc(sizeof *dupe);
+
+ dupe->name = so_strndup(orig->name, orig->namelen);
+ dupe->namelen = orig->namelen;
+
+ dupe->proto = so_strndup(orig->proto, orig->protolen);
+ dupe->protolen = orig->protolen;
+
+ dupe->call = orig->call;
+ dupe->ref = orig->ref;
+ 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;
+}
+
+OP *sub_op_study(const 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;
+}
+
+/* --- Private helpers ----------------------------------------------------- */
+
+STATIC IV so_hint(pTHX) {
+#define so_hint() so_hint(aTHX)
SV *hint;
#if SO_HAS_PERL(5, 9, 5)
return (SvOK(hint) && SvIOK(hint)) ? SvIVX(hint) : 0;
}
-STATIC OP *(*sub_op_old_ck_entersub)(pTHX_ OP *) = 0;
+STATIC OP *so_find_gvop(const OP *o) {
+ OP *ex_list, *last_arg, *rv2cv, *gvop;
-STATIC OP *sub_op_ck_entersub(pTHX_ OP *o) {
- o = CALL_FPTR(sub_op_old_ck_entersub)(aTHX_ o);
+ ex_list = cUNOPo->op_first;
+ /* pushmark when a method call */
+ if (!ex_list || ex_list->op_type != OP_NULL)
+ goto skip;
- if (sub_op_hint()) {
- dMY_CXT;
- U32 hash = 0;
- SV *pkg, *name, *pp_sv;
+ rv2cv = cUNOPx(ex_list)->op_first;
+ if (!rv2cv)
+ goto skip;
- pkg = av_pop(MY_CXT.next_pkg);
- if (!SvOK(pkg))
- return o;
+ while (1) {
+ OP *next = rv2cv->op_sibling;
+ if (!next)
+ break;
+ rv2cv = next;
+ }
- name = av_pop(MY_CXT.next_name);
- if (!SvOK(name)) {
- SvREFCNT_dec(pkg);
- return o;
- }
+ if (!(rv2cv->op_flags & OPf_KIDS))
+ goto skip;
- {
- HV *stash = gv_stashsv(pkg, 0);
-
- if (stash) {
- HE *he = hv_fetch_ent(stash, name, 0, 0);
-
- if (he) {
- CV *cv;
- SV *gv = HeVAL(he);
- hash = HeHASH(he);
-
- 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_ent(stash, name, G_DISCARD, hash);
- }
- }
- }
- }
+ gvop = cUNOPx(rv2cv)->op_first;
+ if (gvop && gvop->op_type == OP_GV)
+ return gvop;
- {
- HE *he = hv_fetch_ent(MY_CXT.map, name, 0, hash);
- if (!he)
- goto skip;
+skip:
+ return NULL;
+}
- pp_sv = HeVAL(he);
- if (!SvOK(pp_sv))
- goto skip;
- }
+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 *gvop;
+ GV *gv;
if (o->op_type != OP_ENTERSUB)
goto skip;
if (o->op_private & OPpENTERSUB_AMPER) /* hopefully \&foo */
goto skip;
+ gvop = so_find_gvop(o);
+ if (!gvop)
+ goto skip;
+
+ gv = cGVOPx_gv(gvop);
+
{
- OP *ex_list = cUNOPo->op_first;
- OP *rv2cv, *gvop;
- OP *last_arg = NULL;
+ SV **svp;
+ CV *cv = NULL;
+ const char *name = GvNAME(gv);
+ I32 len = GvNAMELEN(gv);
+ const sub_op_config_t *c;
+ dMY_CXT;
- /* pushmark when a method call */
- if (!ex_list || ex_list->op_type != OP_NULL)
+ svp = hv_fetch(MY_CXT.map, name, len, 0);
+ if (!svp)
goto skip;
- rv2cv = cUNOPx(ex_list)->op_first;
- if (!rv2cv)
- goto skip;
+ c = INT2PTR(const sub_op_config_t *, SvIVX(*svp));
- while (1) {
- OP *next = rv2cv->op_sibling;
- if (!next)
- break;
- last_arg = rv2cv;
- rv2cv = next;
+ if (gv && SvTYPE(gv) >= SVt_PVGV && (cv = GvCV(gv)) == MY_CXT.placeholder) {
+ SvREFCNT_dec(cv);
+ GvCV_set(gv, NULL);
}
- if (!(rv2cv->op_flags & OPf_KIDS))
- goto skip;
+ if (c->call)
+ o = CALL_FPTR(c->call)(aTHX_ o, c->ud);
+ }
+ }
- gvop = cUNOPx(rv2cv)->op_first;
- if (!gvop || gvop->op_type != OP_GV)
- goto skip;
+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);
+ if (!gvop)
+ continue;
+
+ gv = cGVOPx_gv(gvop);
{
- GV *gv = cGVOPx_gv(gvop);
- STRLEN len;
- const char *s = SvPV_const(name, len);
-
- if (GvNAMELEN(gv) == len && strnEQ(GvNAME(gv), s, len)) {
- o->op_type = OP_CUSTOM;
- o->op_ppaddr = INT2PTR(Perl_ppaddr_t, SvIVX(pp_sv));
-
- 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);
+ 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:
- SvREFCNT_dec(pkg);
- SvREFCNT_dec(name);
+ return o;
+}
+
+STATIC OP *(*so_old_ck_gelem)(pTHX_ OP *) = 0;
+
+STATIC OP *so_ck_gelem(pTHX_ OP *o) {
+ o = CALL_FPTR(so_old_ck_entersub)(aTHX_ o);
+
+ if (so_hint()) {
+ OP *rv2gv, *gvop;
+ GV *gv;
+
+ rv2gv = cUNOPo->op_first;
+ if (!rv2gv)
+ goto skip;
+
+ gvop = cUNOPx(rv2gv)->op_first;
+ if (!gvop || gvop->op_type != OP_GV)
+ goto skip;
+
+ gv = cGVOPx_gv(gvop);
+ if (!gv)
+ goto skip;
+
+ {
+ CV *cv;
+ dMY_CXT;
+
+ if (gv && SvTYPE(gv) >= SVt_PVGV && (cv = GvCV(gv)) == MY_CXT.placeholder) {
+ SvREFCNT_dec(cv);
+ GvCV_set(gv, NULL);
+ }
+ }
}
+skip:
return o;
}
{
MY_CXT_INIT;
MY_CXT.map = newHV();
- MY_CXT.next_pkg = newAV();
- MY_CXT.next_name = newAV();
MY_CXT.placeholder = NULL;
#if SO_THREADSAFE
MY_CXT.owner = aTHX;
#endif /* SO_THREADSAFE */
- sub_op_old_ck_entersub = PL_check[OP_ENTERSUB];
- PL_check[OP_ENTERSUB] = sub_op_ck_entersub;
+ so_ck_replace(OP_ENTERSUB, so_ck_entersub, &so_old_ck_entersub);
+ so_ck_replace(OP_REFGEN, so_ck_refgen, &so_old_ck_refgen);
+ so_ck_replace(OP_GELEM, so_ck_gelem, &so_old_ck_gelem);
}
#if SO_THREADSAFE
HV *map;
CV *placeholder;
tTHX owner;
-CODE:
+PPCODE:
{
dMY_CXT;
owner = MY_CXT.owner;
{
MY_CXT_CLONE;
MY_CXT.map = map;
- MY_CXT.next_pkg = newAV();
- MY_CXT.next_name = newAV();
MY_CXT.placeholder = placeholder;
- MY_CXT.owner = aTHX;
+ MY_CXT.owner = aTHX;
}
+ XSRETURN(0);
#endif /* SO_THREADSAFE */
XSRETURN(0);
void
-_incoming(SV *name, SV *pkg)
-PROTOTYPE: $$
+_constant_sub(SV *sv)
+PROTOTYPE: $
PPCODE:
- dMY_CXT;
- av_push(MY_CXT.next_pkg, SvREFCNT_inc(pkg));
- av_push(MY_CXT.next_name, SvREFCNT_inc(name));
- XSRETURN(0);
+ if (!SvROK(sv))
+ XSRETURN_UNDEF;
+ sv = SvRV(sv);
+ if (SvTYPE(sv) < SVt_PVCV)
+ XSRETURN_UNDEF;
+ ST(0) = sv_2mortal(newSVuv(CvCONST(sv)));
+ XSRETURN(1);
-void
-_custom_name(SV *op)
+SV *
+_get_prototype(SV *name)
PROTOTYPE: $
PREINIT:
- OP *o;
- SV *key;
HE *he;
+ const sub_op_config_t *c;
PPCODE:
- if (!SvROK(op))
- XSRETURN_UNDEF;
- o = INT2PTR(OP *, SvIV(SvRV(op)));
- if (!o || o->op_type != OP_CUSTOM)
- XSRETURN_UNDEF;
- key = newSViv(PTR2IV(o->op_ppaddr));
- he = hv_fetch_ent(PL_custom_op_names, key, 0, 0);
- SvREFCNT_dec(key);
+ dMY_CXT;
+ he = hv_fetch_ent(MY_CXT.map, name, 0, 0);
if (!he)
XSRETURN_UNDEF;
- ST(0) = sv_mortalcopy(HeVAL(he));
+ 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);
projects / perl / modules / Sub-Op.git / blobdiff