X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=Op.xs;h=fe67d0838e80e459cefcb49c9bcee3d9af81d18a;hb=61188a20996808b5a4ad19cc35d272ff7d83b8f1;hp=ba33ea64b18c43d966768bcfc72a20d28ea43497;hpb=a64f1396138777dcc234bef8dd2a964164077061;p=perl%2Fmodules%2FSub-Op.git

diff --git a/Op.xs b/Op.xs
index ba33ea6..fe67d08 100644
--- a/Op.xs
+++ b/Op.xs
@@ -92,6 +92,25 @@ 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 *sub_op_name = NULL;
+
+#ifdef USE_ITHREADS
+STATIC perl_mutex sub_op_name_mutex;
+#endif
+
+typedef struct {
+ STRLEN len;
+ char   buf;
+} sub_op_name_t;
+
 /* --- Public API ---------------------------------------------------------- */
 
 #include "sub_op.h"
@@ -180,115 +199,138 @@ STATIC OP *sub_op_ck_entersub(pTHX_ OP *o) {
  o = CALL_FPTR(sub_op_old_ck_entersub)(aTHX_ o);
 
  if (sub_op_hint()) {
-  dMY_CXT;
-  U32 hash = 0;
-  SV *pkg, *name, *pp_sv;
+  OP *ex_list, *rv2cv, *gvop, *last_arg = NULL;
+  GV *gv;
 
-  pkg  = av_pop(MY_CXT.next_pkg);
-  if (!SvOK(pkg))
-   return o;
-
-  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;
+   HV *stash = GvSTASH(gv);
+   SV *pp_sv, **svp;
+   CV *cv = NULL;
+   const char *name = GvNAME(gv);
+   I32         len  = GvNAMELEN(gv);
+   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)
+   pp_sv = *svp;
+   if (!pp_sv || !SvOK(pp_sv))
     goto skip;
 
-   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 (!GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIO(gv) && !GvFORM(gv)) {
+     (void) hv_delete(stash, name, len, G_DISCARD);
+    }
    }
 
-   if (!(rv2cv->op_flags & OPf_KIDS))
-    goto skip;
+   o->op_type   = OP_CUSTOM;
+   o->op_ppaddr = INT2PTR(Perl_ppaddr_t, SvIVX(pp_sv));
 
-   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);
 
    {
-    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);
+    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);
+
+   {
+    sub_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);
+#endif /* USE_ITHREADS */
+    ptable_store(sub_op_name, o, on);
+#ifdef USE_ITHREADS
+    MUTEX_UNLOCK(&sub_op_name_mutex);
+#endif /* USE_ITHREADS */
+   }
   }
+ }
 
 skip:
-  SvREFCNT_dec(pkg);
-  SvREFCNT_dec(name);
+ return o;
+}
+
+STATIC OP *(*sub_op_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);
+
+ if (sub_op_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;
+    if (!GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIO(gv) && !GvFORM(gv)) {
+     (void)hv_delete(GvSTASH(gv), GvNAME_get(gv), GvNAMELEN_get(gv), G_DISCARD);
+    }
+   }
+  }
  }
 
+skip:
  return o;
 }
 
@@ -300,6 +342,11 @@ PROTOTYPES: ENABLE
 
 BOOT:
 {
+ sub_op_name = ptable_new();
+#ifdef USE_ITHREADS
+ MUTEX_INIT(&sub_op_name_mutex);
+#endif
+
  MY_CXT_INIT;
  MY_CXT.map         = newHV();
  MY_CXT.next_pkg    = newAV();
@@ -311,6 +358,8 @@ BOOT:
 
  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;
 }
 
 #if SO_THREADSAFE
@@ -335,7 +384,7 @@ CODE:
   MY_CXT.next_pkg    = newAV();
   MY_CXT.next_name   = newAV();
   MY_CXT.placeholder = placeholder;
-  MY_CXT.owner = aTHX;
+  MY_CXT.owner       = aTHX;
  }
 
 #endif /* SO_THREADSAFE */
@@ -354,32 +403,26 @@ 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;
+ sub_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(&sub_op_name_mutex);
+#endif /* USE_ITHREADS */
+ on = ptable_fetch(sub_op_name, o);
+#ifdef USE_ITHREADS
+ MUTEX_UNLOCK(&sub_op_name_mutex);
+#endif /* USE_ITHREADS */
+ if (!on)
   XSRETURN_UNDEF;
- ST(0) = sv_mortalcopy(HeVAL(he));
+ ST(0) = sv_2mortal(newSVpvn(&on->buf, on->len));
  XSRETURN(1);