X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FSub-Op.git;a=blobdiff_plain;f=Op.xs;h=17fa468fc11fad06ff19b269e215cdb9acdf4541;hp=5c9413b18afdeb95f7e69f654532d2649d45ee15;hb=159088ccddecdea45fdae8093319b41c097adc86;hpb=0661466030b3dd0fb805da10aaed883fbe931093

diff --git a/Op.xs b/Op.xs
index 5c9413b..17fa468 100644
--- a/Op.xs
+++ b/Op.xs
@@ -55,8 +55,6 @@
 
 typedef struct {
  HV  *map;
- AV  *next_pkg;
- AV  *next_name;
  CV  *placeholder;
 #if SO_THREADSAFE
  tTHX owner;
@@ -92,68 +90,86 @@ STATIC SV *so_clone(pTHX_ SV *sv, tTHX owner) {
 
 #endif /* SO_THREADSAFE */
 
+#define PTABLE_NAME        ptable
+#define PTABLE_VAL_FREE(V) PerlMemShared_free(V)
+
+#include "ptable.h"
+
+/* PerlMemShared_free() needs the [ap]PTBLMS_? default values */
+#define ptable_store(T, K, V) ptable_store(aPTBLMS_ (T), (K), (V))
+
+STATIC ptable *so_op_name = NULL;
+
+#ifdef USE_ITHREADS
+STATIC perl_mutex so_op_name_mutex;
+#endif
+
+typedef struct {
+ STRLEN len;
+ char   buf;
+} 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;
 }
 
-STATIC IV sub_op_hint(pTHX) {
-#define sub_op_hint() sub_op_hint(aTHX)
+void sub_op_free(pTHX_ sub_op_config_t *c) {
+ PerlMemShared_free((char *) c->name);
+ PerlMemShared_free(c);
+
+ return;
+}
+
+/* --- Private helpers ----------------------------------------------------- */
+
+STATIC IV so_hint(pTHX) {
+#define so_hint() so_hint(aTHX)
  SV *hint;
 
 #if SO_HAS_PERL(5, 9, 5)
@@ -174,123 +190,129 @@ 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 *sub_op_ck_entersub(pTHX_ OP *o) {
- dMY_CXT;
-
- o = CALL_FPTR(sub_op_old_ck_entersub)(aTHX_ o);
+STATIC OP *(*so_old_ck_entersub)(pTHX_ OP *) = 0;
 
- if (sub_op_hint()) {
-  dMY_CXT;
-  U32 hash = 0;
-  SV *pkg, *name, *pp_sv;
+STATIC OP *so_ck_entersub(pTHX_ OP *o) {
+ o = CALL_FPTR(so_old_ck_entersub)(aTHX_ o);
 
-  pkg  = av_pop(MY_CXT.next_pkg);
-  if (!SvOK(pkg))
-   return o;
+ if (so_hint()) {
+  OP *ex_list, *rv2cv, *gvop, *last_arg = NULL;
+  GV *gv;
 
-  name = av_pop(MY_CXT.next_name);
-  if (!SvOK(name)) {
-   SvREFCNT_dec(pkg);
-   return o;
-  }
+  if (o->op_type != OP_ENTERSUB)
+   goto skip;
+  if (o->op_private & OPpENTERSUB_AMPER) /* hopefully \&foo */
+   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);
-     }
-    }
-   }
-  }
+  ex_list = cUNOPo->op_first;
+  /* pushmark when a method call */
+  if (!ex_list || ex_list->op_type != OP_NULL)
+   goto skip;
 
-  {
-   HE *he = hv_fetch_ent(MY_CXT.map, name, 0, hash);
-   if (!he)
-    goto skip;
+  rv2cv = cUNOPx(ex_list)->op_first;
+  if (!rv2cv)
+   goto skip;
 
-   pp_sv = HeVAL(he);
-   if (!SvOK(pp_sv))
-    goto skip;
+  while (1) {
+   OP *next = rv2cv->op_sibling;
+   if (!next)
+    break;
+   last_arg = rv2cv;
+   rv2cv    = next;
   }
 
-  if (o->op_type != OP_ENTERSUB)
+  if (!(rv2cv->op_flags & OPf_KIDS))
    goto skip;
-  if (o->op_private & OPpENTERSUB_AMPER) /* hopefully \&foo */
+
+  gvop = cUNOPx(rv2cv)->op_first;
+  if (!gvop || gvop->op_type != OP_GV)
    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(gv) = NULL;
    }
 
-   if (!(rv2cv->op_flags & OPf_KIDS))
-    goto skip;
+   o->op_type   = OP_CUSTOM;
+   o->op_ppaddr = c->pp;
 
-   gvop = cUNOPx(rv2cv)->op_first;
-   if (!gvop || gvop->op_type != OP_GV)
-    goto skip;
+   if (last_arg)
+    last_arg->op_sibling = NULL;
+
+   op_free(rv2cv);
+
+   if (c->check)
+    o = CALL_FPTR(c->check)(aTHX_ o, c->ud);
 
    {
-    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);
-    }
+    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 */
    }
   }
+ }
 
 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(gv) = NULL;
+   }
+  }
  }
 
+skip:
  return o;
 }
 
@@ -302,17 +324,22 @@ 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.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_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
@@ -324,7 +351,7 @@ PREINIT:
  HV  *map;
  CV  *placeholder;
  tTHX owner;
-CODE:
+PPCODE:
  {
   dMY_CXT;
   owner       = MY_CXT.owner;
@@ -334,11 +361,10 @@ CODE:
  {
   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 */
 
@@ -356,32 +382,38 @@ PPCODE:
  }
  XSRETURN(0);
 
-void
-_incoming(SV *name, SV *pkg)
-PROTOTYPE: $$
-PPCODE:
- dMY_CXT;
- av_push(MY_CXT.next_pkg,  SvREFCNT_inc(pkg));
- av_push(MY_CXT.next_name, SvREFCNT_inc(name));
- XSRETURN(0);
-
 void
 _custom_name(SV *op)
 PROTOTYPE: $
 PREINIT:
  OP *o;
- SV *key;
- HE *he;
+ so_op_name_t *on;
 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);
- if (!he)
+#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)
+  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_mortalcopy(HeVAL(he));
+ ST(0) = sv_2mortal(newSVuv(CvCONST(sv)));
  XSRETURN(1);