From: Vincent Pit <vince@profvince.com>
Date: Fri, 1 Jan 2010 22:14:59 +0000 (+0100)
Subject: Stop passing the package and the name from the magical callback to the check function
X-Git-Tag: v0.01~15
X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FSub-Op.git;a=commitdiff_plain;h=3b39085a294ef16114b0d119dc8ebdecbe87fb51

Stop passing the package and the name from the magical callback to the check function

We can infer those from the gv.

Also, properly delete the placeholder when testing if the symbol exists
by hooking into the gelem check function.
---

diff --git a/Op.xs b/Op.xs
index ba33ea6..b1ecdb4 100644
--- a/Op.xs
+++ b/Op.xs
@@ -180,115 +180,124 @@ 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;
-
-  pkg  = av_pop(MY_CXT.next_pkg);
-  if (!SvOK(pkg))
-   return o;
+  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;
+   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);
   }
+ }
 
 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;
 }
 
@@ -311,6 +320,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 +346,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,15 +365,6 @@ 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: $
diff --git a/lib/Sub/Op.pm b/lib/Sub/Op.pm
index a7ad9f9..6459b04 100644
--- a/lib/Sub/Op.pm
+++ b/lib/Sub/Op.pm
@@ -117,8 +117,6 @@ my $sw = Variable::Magic::wizard(
   my $pkg = $data->{pkg};
   my $fqn = join '::', $pkg, $name;
 
-  _incoming($name, $pkg);
-
   no strict 'refs';
   *$fqn = $placeholder unless exists &$fqn;
 
diff --git a/t/10-base.t b/t/10-base.t
index 891a8cb..1f785e5 100644
--- a/t/10-base.t
+++ b/t/10-base.t
@@ -5,7 +5,7 @@ use warnings;
 
 use blib 't/Sub-Op-Test';
 
-use Test::More tests => 2 * 15 + 3 * 1 + 2 * 23;
+use Test::More tests => 2 * 15 + 3 * 2 + 2 * 28;
 
 our $called;
 
@@ -142,3 +142,7 @@ foo 1;
 bar 2;
 ----
 foo, bar # () # [ 1 ], [ 2 ] # foo, bar
+####
+foo 1, foo(2), 3, bar(4, foo(bar, 5), 6);
+----
+foo, bar # @_ # [ 2 ], [ ], [ 5 ], [ 4, 5, 6 ], [ 1, 2, 3, 4, 5, 6 ] # foo, bar, foo, bar, foo