From: Vincent Pit <vince@profvince.com>
Date: Thu, 22 Apr 2010 14:30:41 +0000 (+0200)
Subject: Add preliminary support for hooking reference constructors
X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FSub-Op.git;a=commitdiff_plain;h=302bf09fbd4b673e199bdd22b330ebbdbec4e1fe

Add preliminary support for hooking reference constructors
---

diff --git a/Op.xs b/Op.xs
index 16b9f46..f101fa7 100644
--- a/Op.xs
+++ b/Op.xs
@@ -120,6 +120,7 @@ void sub_op_init(sub_op_config_t *c) {
  c->protolen = 0;
  c->pp       = 0;
  c->check    = 0;
+ c->ref      = 0;
  c->ud       = NULL;
 
  return;
@@ -173,6 +174,7 @@ sub_op_config_t *sub_op_dup(pTHX_ const sub_op_config_t *orig) {
 
  dupe->pp    = orig->pp;
  dupe->check = orig->check;
+ dupe->ref   = orig->ref;
  dupe->ud    = orig->ud;
 
  return dupe;
@@ -209,13 +211,55 @@ STATIC IV so_hint(pTHX) {
  return (SvOK(hint) && SvIOK(hint)) ? SvIVX(hint) : 0;
 }
 
+STATIC OP *so_find_gvop(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;
+}
+
 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 *ex_list, *last_arg, *rv2cv, *gvop;
   GV *gv;
 
   if (o->op_type != OP_ENTERSUB)
@@ -223,28 +267,8 @@ 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, &last_arg, &rv2cv);
+  if (!gvop)
    goto skip;
 
   gv = cGVOPx_gv(gvop);
@@ -299,6 +323,72 @@ 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, NULL, NULL);
+   if (!gvop)
+    continue;
+
+   gv = cGVOPx_gv(gvop);
+
+   {
+    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:
+ return o;
+}
+
 STATIC OP *(*so_old_ck_gelem)(pTHX_ OP *) = 0;
 
 STATIC OP *so_ck_gelem(pTHX_ OP *o) {
@@ -357,6 +447,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;
 }
diff --git a/sub_op.h b/sub_op.h
index 12db025..6a5d9ed 100644
--- a/sub_op.h
+++ b/sub_op.h
@@ -13,6 +13,7 @@ typedef struct {
  STRLEN         protolen;
  Perl_ppaddr_t  pp;
  sub_op_check_t check;
+ sub_op_check_t ref;
  void          *ud;
 } sub_op_config_t;
 
diff --git a/t/Sub-Op-LexicalSub/LexicalSub.xs b/t/Sub-Op-LexicalSub/LexicalSub.xs
index a60fa20..62e83f8 100644
--- a/t/Sub-Op-LexicalSub/LexicalSub.xs
+++ b/t/Sub-Op-LexicalSub/LexicalSub.xs
@@ -22,6 +22,12 @@ STATIC OP *sols_check(pTHX_ OP *o, void *ud_) {
  return o;
 }
 
+STATIC OP *sols_ref(pTHX_ OP *o, void *ud_) {
+ SV *cb = ud_;
+
+ return newSVOP(OP_ANONCODE, o->op_flags & ~OPf_KIDS, cb);
+}
+
 STATIC OP *sols_pp(pTHX) {
  dSP;
  SV *cb;
@@ -68,6 +74,7 @@ PPCODE:
     c.proto = SvPV_const(cb, c.protolen);
    }
    c.check  = sols_check;
+   c.ref    = sols_ref;
    c.ud     = SvREFCNT_inc(cb);
    c.pp     = sols_pp;
    sub_op_register(aTHX_ &c, 0);