From: Vincent Pit <vince@profvince.com>
Date: Fri, 20 Feb 2009 22:28:00 +0000 (+0100)
Subject: Bless the op info object into the right class (stealing the logic from B)
X-Git-Tag: v0.32~21
X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FVariable-Magic.git;a=commitdiff_plain;h=20cd6add9786108c0b4c6967b6ea02ae9d5cef4d

Bless the op info object into the right class (stealing the logic from B)
---

diff --git a/Magic.xs b/Magic.xs
index 3b9adfc..35500ef 100644
--- a/Magic.xs
+++ b/Magic.xs
@@ -199,13 +199,116 @@ STATIC void vmg_sv_magicuvar(pTHX_ SV *sv, const char *uf, I32 len) {
 
 #endif /* VMG_UVAR */
 
+/* --- Stolen chunk of B --------------------------------------------------- */
+
+typedef enum {
+ OPc_NULL   = 0,
+ OPc_BASEOP = 1,
+ OPc_UNOP   = 2,
+ OPc_BINOP  = 3,
+ OPc_LOGOP  = 4,
+ OPc_LISTOP = 5,
+ OPc_PMOP   = 6,
+ OPc_SVOP   = 7,
+ OPc_PADOP  = 8,
+ OPc_PVOP   = 9,
+ OPc_LOOP   = 10,
+ OPc_COP    = 11,
+ OPc_MAX    = 12
+} opclass;
+
+STATIC const char *const vmg_opclassnames[] = {
+ "B::NULL",
+ "B::OP",
+ "B::UNOP",
+ "B::BINOP",
+ "B::LOGOP",
+ "B::LISTOP",
+ "B::PMOP",
+ "B::SVOP",
+ "B::PADOP",
+ "B::PVOP",
+ "B::LOOP",
+ "B::COP"
+};
+
+STATIC opclass vmg_opclass(const OP *o) {
+ if (!o)
+  return OPc_NULL;
+
+ if (o->op_type == 0)
+  return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
+
+ if (o->op_type == OP_SASSIGN)
+  return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
+
+ if (o->op_type == OP_AELEMFAST) {
+  if (o->op_flags & OPf_SPECIAL)
+   return OPc_BASEOP;
+  else
+#ifdef USE_ITHREADS
+   return OPc_PADOP;
+#else
+   return OPc_SVOP;
+#endif
+ }
+
+#ifdef USE_ITHREADS
+ if (o->op_type == OP_GV || o->op_type == OP_GVSV || o->op_type == OP_RCATLINE)
+  return OPc_PADOP;
+#endif
+
+ switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
+  case OA_BASEOP:
+   return OPc_BASEOP;
+  case OA_UNOP:
+   return OPc_UNOP;
+  case OA_BINOP:
+   return OPc_BINOP;
+  case OA_LOGOP:
+   return OPc_LOGOP;
+  case OA_LISTOP:
+   return OPc_LISTOP;
+  case OA_PMOP:
+   return OPc_PMOP;
+  case OA_SVOP:
+   return OPc_SVOP;
+  case OA_PADOP:
+   return OPc_PADOP;
+  case OA_PVOP_OR_SVOP:
+   return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF)) ? OPc_SVOP : OPc_PVOP;
+  case OA_LOOP:
+   return OPc_LOOP;
+  case OA_COP:
+   return OPc_COP;
+  case OA_BASEOP_OR_UNOP:
+   return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
+  case OA_FILESTATOP:
+   return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
+#ifdef USE_ITHREADS
+           (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP);
+#else
+           (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP);
+#endif
+  case OA_LOOPEXOP:
+   if (o->op_flags & OPf_STACKED)
+    return OPc_UNOP;
+   else if (o->op_flags & OPf_SPECIAL)
+    return OPc_BASEOP;
+   else
+    return OPc_PVOP;
+ }
+
+ return OPc_BASEOP;
+}
+
 /* --- Context-safe global data -------------------------------------------- */
 
 #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
 
 typedef struct {
  HV *wizards;
- HV *b__op_stash;
+ HV *b__op_stashes[OPc_MAX];
 } my_cxt_t;
 
 START_MY_CXT
@@ -517,9 +620,11 @@ STATIC void vmg_op_info_init(pTHX_ unsigned int opinfo) {
    break;
   case VMG_OP_INFO_OBJECT: {
    dMY_CXT;
-   if (!MY_CXT.b__op_stash) {
+   if (!MY_CXT.b__op_stashes[0]) {
+    opclass c;
     require_pv("B.pm");
-    MY_CXT.b__op_stash = gv_stashpv("B::OP", 1);
+    for (c = 0; c < OPc_MAX; ++c)
+     MY_CXT.b__op_stashes[c] = gv_stashpv(vmg_opclassnames[c], 1);
    }
    break;
   }
@@ -541,7 +646,7 @@ STATIC SV *vmg_op_info(pTHX_ unsigned int opinfo) {
   case VMG_OP_INFO_OBJECT: {
    dMY_CXT;
    return sv_bless(sv_2mortal(newRV_noinc(newSViv(PTR2IV(PL_op)))),
-                              MY_CXT.b__op_stash);
+                           gv_stashpv(vmg_opclassnames[vmg_opclass(PL_op)], 1));
   }
   default:
    break;
@@ -1080,7 +1185,7 @@ BOOT:
  MY_CXT_INIT;
  MY_CXT.wizards = newHV();
  hv_iterinit(MY_CXT.wizards); /* Allocate iterator */
- MY_CXT.b__op_stash = NULL;
+ MY_CXT.b__op_stashes[0] = NULL;
  stash = gv_stashpv(__PACKAGE__, 1);
  newCONSTSUB(stash, "SIG_MIN",   newSVuv(SIG_MIN));
  newCONSTSUB(stash, "SIG_MAX",   newSVuv(SIG_MAX));
@@ -1111,6 +1216,7 @@ PROTOTYPE: DISABLE
 PREINIT:
  HV *hv;
  U32 had_b__op_stash = 0;
+ opclass c;
 CODE:
  {
   HE *key;
@@ -1132,13 +1238,18 @@ CODE:
    SvREADONLY_on(sv);
    if (!hv_store(hv, sig, len, sv, HeHASH(key))) croak("%s during CLONE", vmg_globstorefail);
   }
-  if (MY_CXT.b__op_stash)
-   had_b__op_stash = 1;
+  for (c = 0; c < OPc_MAX; ++c) {
+   if (MY_CXT.b__op_stashes[c])
+    had_b__op_stash |= (((U32) 1) << c);
+  }
  }
  {
   MY_CXT_CLONE;
   MY_CXT.wizards     = hv;
-  MY_CXT.b__op_stash = had_b__op_stash ? gv_stashpv("B::OP", 1) : NULL;
+  for (c = 0; c < OPc_MAX; ++c) {
+   MY_CXT.b__op_stashes[c] = (had_b__op_stash & (((U32) 1) << c))
+                              ? gv_stashpv("B::OP", 1) : NULL;
+  }
  }
 
 #endif /* VMG_THREADSAFE */
diff --git a/t/14-callbacks.t b/t/14-callbacks.t
index eae92fd..1f2c2de 100644
--- a/t/14-callbacks.t
+++ b/t/14-callbacks.t
@@ -65,7 +65,8 @@ is_deeply(\@callers, [
  ([ 'main', $0, __LINE__-3 ]) x 2,
 ], 'caller into callback into eval returns the right thing');
 
-for ([ 'get', '$c', 'sassign' ], [ 'len', '@c', 'padav' ]) {
+for ([ 'get', '$c', [ 'sassign', 'B::BINOP' ] ],
+     [ 'len', '@c', [ 'padav',   'B::OP'    ] ]) {
  my ($key, $var, $exp) = @$_;
 
  for my $op_info (VMG_OP_INFO_NAME, VMG_OP_INFO_OBJECT, 3) {
@@ -79,10 +80,10 @@ for ([ 'get', '$c', 'sassign' ], [ 'len', '@c', 'padav' ]) {
     my $op = $_[-1];
     my $desc = "$key magic with op_info == $op_info";
     if ($op_info == 1) {
-     is $op, $exp, "$desc gets the right op info";
+     is $op, $exp->[0], "$desc gets the right op info";
     } elsif ($op_info == 2) {
-     isa_ok $op, 'B::OP', $desc;
-     is $op->name, $exp, "$desc gets the right op info";
+     isa_ok $op, $exp->[1], $desc;
+     is $op->name, $exp->[0], "$desc gets the right op info";
     } else {
      is $op, undef, "$desc gets the right op info";
     }