X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=Op.xs;h=91f07cc2aeec34ed2a457e38e506e9b813fc442f;hb=efeaaece7f45dd3c188aca0094d050ea242d4bb6;hp=634ddc873f87e8297bf1dc030b9b1a32ba3730ed;hpb=a0c0873977f66d8024a988b8dbd8e1c092927189;p=perl%2Fmodules%2FSub-Op.git

diff --git a/Op.xs b/Op.xs
index 634ddc8..91f07cc 100644
--- a/Op.xs
+++ b/Op.xs
@@ -90,50 +90,109 @@ STATIC SV *so_clone(pTHX_ SV *sv, tTHX owner) {
 
 #endif /* SO_THREADSAFE */
 
-#define PTABLE_NAME        ptable
-#define PTABLE_VAL_FREE(V) PerlMemShared_free(V)
+/* --- Public API ---------------------------------------------------------- */
+
+#include "sub_op.h"
 
-#include "ptable.h"
+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;
 
-/* PerlMemShared_free() needs the [ap]PTBLMS_? default values */
-#define ptable_store(T, K, V) ptable_store(aPTBLMS_ (T), (K), (V))
+ return;
+}
 
-STATIC ptable *so_op_name = NULL;
+void sub_op_register(pTHX_ const sub_op_config_t *c, U32 flags) {
+ dMY_CXT;
 
-#ifdef USE_ITHREADS
-STATIC perl_mutex so_op_name_mutex;
-#endif
+ if (!(flags & SUB_OP_REGISTER_STEAL))
+  c = sub_op_dup(aTHX_ c);
 
-typedef struct {
+ (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;
- char   buf;
-} so_op_name_t;
+ sub_op_config_t *dupe = PerlMemShared_malloc(sizeof *dupe);
+
+ 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;
 
-/* --- Public API ---------------------------------------------------------- */
+ dupe->call = orig->call;
+ dupe->ref  = orig->ref;
+ dupe->ud   = orig->ud;
 
-#include "sub_op.h"
+ return dupe;
+}
 
-void sub_op_register(pTHX_ const sub_op_config_t *c) {
- SV *key = newSViv(PTR2IV(c->pp));
+void sub_op_free(pTHX_ sub_op_config_t *c) {
+ PerlMemShared_free((char *) c->name);
+ PerlMemShared_free(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);
+ return;
+}
 
- if (!PL_custom_op_descs)
-  PL_custom_op_descs = newHV();
- (void) hv_store_ent(PL_custom_op_descs, key, newSVpv(c->name, c->namelen), 0);
+OP *sub_op_study(const OP *o, OP **last_arg_p, OP **rv2cv_p) {
+ OP *ex_list, *last_arg, *rv2cv, *gvop;
 
- if (c->check) {
-  SV *check = newSViv(PTR2IV(c->check));
-  sv_magicext(key, check, PERL_MAGIC_ext, NULL, c->ud, 0);
-  SvREFCNT_dec(check);
- }
+ ex_list = cUNOPo->op_first;
+ /* pushmark when a method call */
+ if (!ex_list || ex_list->op_type != OP_NULL)
+  goto skip;
 
- {
-  dMY_CXT;
-  (void) hv_store(MY_CXT.map, c->name, c->namelen, key, 0);
+ 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 ----------------------------------------------------- */
@@ -160,13 +219,43 @@ STATIC IV so_hint(pTHX) {
  return (SvOK(hint) && SvIOK(hint)) ? SvIVX(hint) : 0;
 }
 
+STATIC OP *so_find_gvop(const OP *o) {
+ 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;
+  rv2cv = next;
+ }
+
+ if (!(rv2cv->op_flags & OPf_KIDS))
+  goto skip;
+
+ gvop = cUNOPx(rv2cv)->op_first;
+ if (gvop && gvop->op_type == OP_GV)
+  return gvop;
+
+skip:
+ return NULL;
+}
+
 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 *gvop;
   GV *gv;
 
   if (o->op_type != OP_ENTERSUB)
@@ -174,80 +263,98 @@ 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);
+  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);
     GvCV(gv) = NULL;
    }
 
-   o->op_type   = OP_CUSTOM;
-   o->op_ppaddr = INT2PTR(Perl_ppaddr_t, SvIVX(pp_sv));
+   if (c->call)
+    o = CALL_FPTR(c->call)(aTHX_ o, c->ud);
+  }
+ }
 
-   if (last_arg)
-    last_arg->op_sibling = NULL;
+skip:
+ return o;
+}
 
-   op_free(rv2cv);
+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);
 
    {
-    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);
-    }
+    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));
    }
 
-   {
-    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(&so_op_name_mutex);
-#endif /* USE_ITHREADS */
-    ptable_store(so_op_name, o, on);
-#ifdef USE_ITHREADS
-    MUTEX_UNLOCK(&so_op_name_mutex);
-#endif /* USE_ITHREADS */
+   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;
+    }
    }
   }
  }
@@ -300,11 +407,6 @@ PROTOTYPES: ENABLE
 
 BOOT:
 {
- so_op_name = ptable_new();
-#ifdef USE_ITHREADS
- MUTEX_INIT(&so_op_name_mutex);
-#endif
-
  MY_CXT_INIT;
  MY_CXT.map         = newHV();
  MY_CXT.placeholder = NULL;
@@ -314,6 +416,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;
 }
@@ -359,37 +463,30 @@ PPCODE:
  XSRETURN(0);
 
 void
-_custom_name(SV *op)
+_constant_sub(SV *sv)
 PROTOTYPE: $
-PREINIT:
- OP *o;
- so_op_name_t *on;
 PPCODE:
- if (!SvROK(op))
-  XSRETURN_UNDEF;
- o = INT2PTR(OP *, SvIV(SvRV(op)));
- if (!o || o->op_type != OP_CUSTOM)
+ if (!SvROK(sv))
   XSRETURN_UNDEF;
-#ifdef USE_ITHREADS
- MUTEX_LOCK(&so_op_name_mutex);
-#endif /* USE_ITHREADS */
- on = ptable_fetch(so_op_name, o);
-#ifdef USE_ITHREADS
- MUTEX_UNLOCK(&so_op_name_mutex);
-#endif /* USE_ITHREADS */
- if (!on)
+ sv = SvRV(sv);
+ if (SvTYPE(sv) < SVt_PVCV)
   XSRETURN_UNDEF;
- ST(0) = sv_2mortal(newSVpvn(&on->buf, on->len));
+ ST(0) = sv_2mortal(newSVuv(CvCONST(sv)));
  XSRETURN(1);
 
-void
-_constant_sub(SV *sv)
+SV *
+_get_prototype(SV *name)
 PROTOTYPE: $
+PREINIT:
+ HE *he;
+ const sub_op_config_t *c;
 PPCODE:
- if (!SvROK(sv))
+ dMY_CXT;
+ he = hv_fetch_ent(MY_CXT.map, name, 0, 0);
+ if (!he)
   XSRETURN_UNDEF;
- sv = SvRV(sv);
- if (SvTYPE(sv) < SVt_PVCV)
+ c = INT2PTR(const sub_op_config_t *, SvIVX(HeVAL(he)));
+ if (!c->proto)
   XSRETURN_UNDEF;
- ST(0) = sv_2mortal(newSVuv(CvCONST(sv)));
+ ST(0) = sv_2mortal(newSVpvn(c->proto, c->protolen));
  XSRETURN(1);