Get current op information in magic callbacks

diff --git a/Magic.xs b/Magic.xs
index e4741147ddbea8a4efef27ac5ba534f629cbe596..aeea182bc94ce8c9db4be1a9ed98c1c15ce9c968 100644 (file)
--- a/Magic.xs
+++ b/Magic.xs
@@ -229,8 +229,11 @@ STATIC U16 vmg_gensig(pTHX) {
 
 typedef struct {
  MGVTBL *vtbl;
+
  U16 sig;
- U16 uvar;
+ U8 uvar;
+ U8 opinfo;
+
  SV *cb_data;
  SV *cb_get, *cb_set, *cb_len, *cb_clear, *cb_free;
 #if MGf_COPY
@@ -486,21 +489,77 @@ STATIC UV vmg_dispell(pTHX_ SV *sv, U16 sig) {
  return 1;
 }
 
+/* ... OP info ............................................................. */
+
+#define VMG_OP_INFO_NAME   1
+#define VMG_OP_INFO_OBJECT 2
+
+STATIC STRLEN *vmg_op_name_len = NULL;
+
+STATIC HV *vmg_b__op_stash = NULL;
+
+STATIC void vmg_op_info_init(pTHX_ unsigned int opinfo) {
+#define vmg_op_info_init(W) vmg_op_info_init(aTHX_ (W))
+ switch (opinfo) {
+  case VMG_OP_INFO_NAME:
+   if (!vmg_op_name_len) {
+    OPCODE t;
+    Newx(vmg_op_name_len, MAXO, STRLEN);
+    for (t = 0; t < OP_max; ++t)
+     vmg_op_name_len[t] = strlen(PL_op_name[t]);
+   }
+   break;
+  case VMG_OP_INFO_OBJECT:
+   if (!vmg_b__op_stash) {
+    require_pv("B.pm");
+    vmg_b__op_stash = gv_stashpv("B::OP", 1);
+   }
+   break;
+  default:
+   break;
+ }
+}
+
+STATIC SV *vmg_op_info(pTHX_ unsigned int opinfo) {
+#define vmg_op_info(W) vmg_op_info(aTHX_ (W))
+ if (!PL_op)
+  return &PL_sv_undef;
+
+ switch (opinfo) {
+  case VMG_OP_INFO_NAME: {
+   OPCODE t = PL_op->op_type;
+   return sv_2mortal(newSVpvn(PL_op_name[t], vmg_op_name_len[t]));
+  }
+  case VMG_OP_INFO_OBJECT:
+   return sv_bless(sv_2mortal(newRV_noinc(newSViv(PTR2IV(PL_op)))),
+                              vmg_b__op_stash);
+  default:
+   break;
+ }
+
+ return &PL_sv_undef;
+}
+
 /* ... svt callbacks ....................................................... */
 
-#define VMG_CB_CALL_ARGS_MASK 15
-#define VMG_CB_CALL_EVAL      16
+#define VMG_CB_CALL_ARGS_MASK  15
+#define VMG_CB_CALL_ARGS_SHIFT 4
+#define VMG_CB_CALL_OPINFO     (VMG_OP_INFO_NAME|VMG_OP_INFO_OBJECT)
+#define VMG_CB_CALL_EVAL       4
 
 STATIC int vmg_cb_call(pTHX_ SV *cb, SV *sv, SV *data, unsigned int flags, ...){
  va_list ap;
  SV *svr;
  int ret;
- unsigned int i;
- unsigned int args = flags & VMG_CB_CALL_ARGS_MASK;
- unsigned int eval = flags & VMG_CB_CALL_EVAL ? G_EVAL : 0;
+ unsigned int i, args, opinfo, eval;
 
  dSP;
 
+ args    = flags & VMG_CB_CALL_ARGS_MASK;
+ flags >>= VMG_CB_CALL_ARGS_SHIFT;
+ opinfo  = flags & VMG_CB_CALL_OPINFO;
+ eval    = flags & VMG_CB_CALL_EVAL ? G_EVAL : 0;
+
  ENTER;
  SAVETMPS;
 
@@ -514,6 +573,8 @@ STATIC int vmg_cb_call(pTHX_ SV *cb, SV *sv, SV *data, unsigned int flags, ...){
   PUSHs(sva ? sva : &PL_sv_undef);
  }
  va_end(ap);
+ if (opinfo)
+  XPUSHs(vmg_op_info(opinfo));
  PUTBACK;
 
  call_sv(cb, G_SCALAR | eval);
@@ -531,21 +592,29 @@ STATIC int vmg_cb_call(pTHX_ SV *cb, SV *sv, SV *data, unsigned int flags, ...){
  return ret;
 }
 
-#define vmg_cb_call1(I, S, D)         vmg_cb_call(aTHX_ (I), (S), (D), 0)
-#define vmg_cb_call1e(I, S, D)        vmg_cb_call(aTHX_ (I), (S), (D), VMG_CB_CALL_EVAL)
-#define vmg_cb_call2(I, S, D, S2)     vmg_cb_call(aTHX_ (I), (S), (D), 1, (S2))
-#define vmg_cb_call3(I, S, D, S2, S3) vmg_cb_call(aTHX_ (I), (S), (D), 2, (S2), (S3))
+#define vmg_cb_call1(I, S, D) \
+        vmg_cb_call(aTHX_ (I), (S), (D), (flags << VMG_CB_CALL_ARGS_SHIFT))
+#define vmg_cb_call2(I, S, D, S2) \
+        vmg_cb_call(aTHX_ (I), (S), (D), ((flags << VMG_CB_CALL_ARGS_SHIFT) | 1), (S2))
+#define vmg_cb_call3(I, S, D, S2, S3) \
+        vmg_cb_call(aTHX_ (I), (S), (D), ((flags << VMG_CB_CALL_ARGS_SHIFT) | 2), (S2), (S3))
 
 STATIC int vmg_svt_get(pTHX_ SV *sv, MAGIC *mg) {
- return vmg_cb_call1(SV2MGWIZ(mg->mg_ptr)->cb_get, sv, mg->mg_obj);
+ const MGWIZ *w = SV2MGWIZ(mg->mg_ptr);
+ unsigned int flags = w->opinfo;
+ return vmg_cb_call1(w->cb_get, sv, mg->mg_obj);
 }
 
 STATIC int vmg_svt_set(pTHX_ SV *sv, MAGIC *mg) {
- return vmg_cb_call1(SV2MGWIZ(mg->mg_ptr)->cb_set, sv, mg->mg_obj);
+ const MGWIZ *w = SV2MGWIZ(mg->mg_ptr);
+ unsigned int flags = w->opinfo;
+ return vmg_cb_call1(w->cb_set, sv, mg->mg_obj);
 }
 
 STATIC U32 vmg_svt_len(pTHX_ SV *sv, MAGIC *mg) {
  SV *svr;
+ const MGWIZ *w = SV2MGWIZ(mg->mg_ptr);
+ unsigned int opinfo = w->opinfo;
  U32 len, ret;
  svtype t = SvTYPE(sv);
 
@@ -573,9 +642,11 @@ STATIC U32 vmg_svt_len(pTHX_ SV *sv, MAGIC *mg) {
   len = 0;
   PUSHs(&PL_sv_undef);
  }
+ if (opinfo)
+  XPUSHs(vmg_op_info(opinfo));
  PUTBACK;
 
- call_sv(SV2MGWIZ(mg->mg_ptr)->cb_len, G_SCALAR);
+ call_sv(w->cb_len, G_SCALAR);
 
  SPAGAIN;
  svr = POPs;
@@ -589,17 +660,24 @@ STATIC U32 vmg_svt_len(pTHX_ SV *sv, MAGIC *mg) {
 }
 
 STATIC int vmg_svt_clear(pTHX_ SV *sv, MAGIC *mg) {
- return vmg_cb_call1(SV2MGWIZ(mg->mg_ptr)->cb_clear, sv, mg->mg_obj);
+ const MGWIZ *w = SV2MGWIZ(mg->mg_ptr);
+ unsigned int flags = w->opinfo;
+ return vmg_cb_call1(w->cb_clear, sv, mg->mg_obj);
 }
 
 STATIC int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) {
  SV *wiz = (SV *) mg->mg_ptr;
+ const MGWIZ *w;
+ unsigned int flags;
  int ret = 0;
 
  /* This may happen in global destruction */
  if (SvTYPE(wiz) == SVTYPEMASK)
   return 0;
 
+ w = SV2MGWIZ(mg->mg_ptr);
+ flags = w->opinfo | VMG_CB_CALL_EVAL;
+
  /* So that it survives the temp cleanup in vmg_cb_call */
  SvREFCNT_inc(sv);
 
@@ -610,7 +688,7 @@ STATIC int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) {
  SvMAGIC_set(sv, mg);
 #endif
 
- ret = vmg_cb_call1e(SV2MGWIZ(wiz)->cb_free, sv, mg->mg_obj);
+ ret = vmg_cb_call1(w->cb_free, sv, mg->mg_obj);
 
  /* Calling SvREFCNT_dec() will trigger destructors in an infinite loop, so
   * we have to rely on SvREFCNT() being a lvalue. Heck, even the core does it */
@@ -630,6 +708,8 @@ STATIC int vmg_svt_copy(pTHX_ SV *sv, MAGIC *mg, SV *nsv, const char *key,
 # endif
  ) {
  SV *keysv;
+ const MGWIZ *w = SV2MGWIZ(mg->mg_ptr);
+ unsigned int flags = w->opinfo;
  int ret;
 
  if (keylen == HEf_SVKEY) {
@@ -638,7 +718,7 @@ STATIC int vmg_svt_copy(pTHX_ SV *sv, MAGIC *mg, SV *nsv, const char *key,
   keysv = newSVpvn(key, keylen);
  }
 
- ret = vmg_cb_call3(SV2MGWIZ(mg->mg_ptr)->cb_copy, sv, mg->mg_obj, keysv, nsv);
+ ret = vmg_cb_call3(w->cb_copy, sv, mg->mg_obj, keysv, nsv);
 
  if (keylen != HEf_SVKEY) {
   SvREFCNT_dec(keysv);
@@ -656,7 +736,9 @@ STATIC int vmg_svt_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) {
 
 #if MGf_LOCAL
 STATIC int vmg_svt_local(pTHX_ SV *nsv, MAGIC *mg) {
- return vmg_cb_call1(SV2MGWIZ(mg->mg_ptr)->cb_local, nsv, mg->mg_obj);
+ const MGWIZ *w = SV2MGWIZ(mg->mg_ptr);
+ unsigned int flags = w->opinfo;
+ return vmg_cb_call1(w->cb_local, nsv, mg->mg_obj);
 }
 #endif /* MGf_LOCAL */
 
@@ -682,7 +764,8 @@ STATIC I32 vmg_svt_val(pTHX_ IV action, SV *sv) {
 
  action &= HV_FETCH_ISSTORE | HV_FETCH_ISEXISTS | HV_FETCH_LVALUE | HV_DELETE;
  for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
-  MGWIZ *w;
+  const MGWIZ *w;
+  unsigned int flags;
   switch (mg->mg_type) {
    case PERL_MAGIC_ext:
     break;
@@ -695,6 +778,7 @@ STATIC I32 vmg_svt_val(pTHX_ IV action, SV *sv) {
   if (mg->mg_private < SIG_MIN || mg->mg_private > SIG_MAX)
    continue;
   w = SV2MGWIZ(mg->mg_ptr);
+  flags = w->opinfo;
   switch (w->uvar) {
    case 0:
     continue;
@@ -935,10 +1019,11 @@ STATIC MGWIZ *vmg_wizard_clone(pTHX_ const MGWIZ *w) {
  VMG_CLONE_CB(exists);
  VMG_CLONE_CB(delete);
 #endif /* VMG_UVAR */
- z->owner = aTHX;
- z->vtbl  = t;
- z->sig   = w->sig;
- z->uvar  = w->uvar;
+ z->owner  = aTHX;
+ z->vtbl   = t;
+ z->sig    = w->sig;
+ z->uvar   = w->uvar;
+ z->opinfo = w->opinfo;
 
  return z;
 }
@@ -975,6 +1060,8 @@ BOOT:
                     newSVuv(VMG_COMPAT_SCALAR_LENGTH_NOLEN));
  newCONSTSUB(stash, "VMG_PERL_PATCHLEVEL", newSVuv(VMG_PERL_PATCHLEVEL));
  newCONSTSUB(stash, "VMG_THREADSAFE",      newSVuv(VMG_THREADSAFE));
+ newCONSTSUB(stash, "VMG_OP_INFO_NAME",    newSVuv(VMG_OP_INFO_NAME));
+ newCONSTSUB(stash, "VMG_OP_INFO_OBJECT",  newSVuv(VMG_OP_INFO_OBJECT));
 }
 
 #if VMG_THREADSAFE
@@ -1025,7 +1112,7 @@ PREINIT:
 CODE:
  dMY_CXT;
 
- if (items != 7
+ if (items != 8
 #if MGf_COPY
               + 1
 #endif /* MGf_COPY */
@@ -1057,6 +1144,10 @@ CODE:
  Newx(w, 1, MGWIZ);
 
  VMG_SET_CB(ST(i++), data);
+ cb = ST(i++);
+ w->opinfo = SvOK(cb) ? SvUV(cb) : 0;
+ if (w->opinfo)
+  vmg_op_info_init(w->opinfo);
  VMG_SET_SVT_CB(ST(i++), get);
  VMG_SET_SVT_CB(ST(i++), set);
  VMG_SET_SVT_CB(ST(i++), len);
@@ -1169,3 +1260,13 @@ CODE:
  RETVAL = newSVuv(vmg_dispell(SvRV(sv), sig));
 OUTPUT:
  RETVAL
+
+void
+_cleanup()
+PROTOTYPE:
+PPCODE:
+ if (vmg_op_name_len) {
+  Safefree(vmg_op_name_len);
+  vmg_op_name_len = NULL;
+ }
+ XSRETURN(0);

diff --git a/lib/Variable/Magic.pm b/lib/Variable/Magic.pm
index 79ca7e9cc7164d945e6a55a24b553db243b9d5e0..b82e214197eeb024a02fb2066aad8ecbbfcb7675 100644 (file)
--- a/lib/Variable/Magic.pm
+++ b/lib/Variable/Magic.pm
@@ -267,6 +267,14 @@ The perl patchlevel this module was built with, or C<0> for non-debugging perls.
 
 True iff this module could have been built with thread-safety features enabled.
 
+=head2 C<VMG_OP_INFO_NAME>
+
+Value to pass with C<op_info> to get the current op name in the magic callbacks.
+
+=head2 C<VMG_OP_INFO_OBJECT>
+
+Value to pass with C<op_info> to get a C<B::OP> object representing the current op in the magic callbacks.
+
 =head1 FUNCTIONS
 
 =cut
@@ -291,7 +299,8 @@ BEGIN {
            store    => sub { my ($ref, $data, $key) = @_; ... },
            exists   => sub { my ($ref, $data, $key) = @_; ... },
            delete   => sub { my ($ref, $data, $key) = @_; ... },
-           copy_key => $bool
+           copy_key => $bool,
+           op_info  => [ 0 | 1 | 2 ]
 
 This function creates a 'wizard', an opaque type that holds the magic information.
 It takes a list of keys / values as argument, whose keys can be :
@@ -321,6 +330,10 @@ C<get>, C<set>, C<len>, C<clear>, C<free>, C<copy>, C<local>, C<fetch>, C<store>
 Code references to the corresponding magic callbacks.
 You don't have to specify all of them : the magic associated with undefined entries simply won't be hooked.
 In those callbacks, C<$_[0]> is always a reference to the magic object and C<$_[1]> is always the private data (or C<undef> when no private data constructor was supplied).
+
+Moreover, when you pass C<< op_info => $num >> to C<wizard>, the last element of C<@_> will be the current op name if C<$num == VMG_OP_INFO_NAME> and a C<B::OP> object representing the current op if C<$num == VMG_OP_INFO_OBJECT>.
+Both have a performance hit, but just getting the name is lighter than getting the op object.
+
 Other arguments are specific to the magic hooked :
 
 =over 8
@@ -366,7 +379,7 @@ However, only the return value of the C<len> callback currently holds a meaning.
 sub wizard {
  croak 'Wrong number of arguments for wizard()' if @_ % 2;
  my %opts = @_;
- my @keys  = qw/sig data get set len clear free/;
+ my @keys = qw/sig data op_info get set len clear free/;
  push @keys, 'copy'  if MGf_COPY;
  push @keys, 'dup'   if MGf_DUP;
  push @keys, 'local' if MGf_LOCAL;
@@ -446,15 +459,19 @@ use base qw/Exporter/;
 our @EXPORT         = ();
 our %EXPORT_TAGS    = (
  'funcs' =>  [ qw/wizard gensig getsig cast getdata dispell/ ],
- 'consts' => [ qw/SIG_MIN SIG_MAX SIG_NBR MGf_COPY MGf_DUP MGf_LOCAL VMG_UVAR/,
-               qw/VMG_COMPAT_ARRAY_PUSH_NOLEN VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID VMG_COMPAT_ARRAY_UNDEF_CLEAR/,
-               qw/VMG_COMPAT_SCALAR_LENGTH_NOLEN/,
+ 'consts' => [
+               qw/SIG_MIN SIG_MAX SIG_NBR MGf_COPY MGf_DUP MGf_LOCAL VMG_UVAR/,
+               qw/VMG_COMPAT_ARRAY_PUSH_NOLEN VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID VMG_COMPAT_ARRAY_UNDEF_CLEAR VMG_COMPAT_SCALAR_LENGTH_NOLEN/,
                qw/VMG_PERL_PATCHLEVEL/,
-               qw/VMG_THREADSAFE/ ]
+               qw/VMG_THREADSAFE/,
+               qw/VMG_OP_INFO_NAME VMG_OP_INFO_OBJECT/
+             ]
 );
 our @EXPORT_OK      = map { @$_ } values %EXPORT_TAGS;
 $EXPORT_TAGS{'all'} = [ @EXPORT_OK ];
 
+END { _cleanup() }
+
 =head1 CAVEATS
 
 If you store a magic object in the private data slot, the magic won't be accessible by L</getdata> since it's not copied by assignation.

diff --git a/t/01-import.t b/t/01-import.t
index 1b9f066803a6f634ce1c502e6be1b0d969f0646b..f02df0e122d3c91b0ee46ed36efeb017966c4612 100644 (file)
--- a/t/01-import.t
+++ b/t/01-import.t
@@ -3,11 +3,18 @@
 use strict;
 use warnings;
 
-use Test::More tests => 19;
+use Test::More tests => 21;
 
 require Variable::Magic;
 
-for (qw/wizard gensig getsig cast getdata dispell SIG_MIN SIG_MAX SIG_NBR MGf_COPY MGf_DUP MGf_LOCAL VMG_UVAR VMG_COMPAT_ARRAY_PUSH_NOLEN VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID VMG_COMPAT_ARRAY_UNDEF_CLEAR VMG_COMPAT_SCALAR_LENGTH_NOLEN VMG_PERL_PATCHLEVEL VMG_THREADSAFE/) {
+for (qw/wizard gensig getsig cast getdata dispell
+        SIG_MIN SIG_MAX SIG_NBR
+        MGf_COPY MGf_DUP MGf_LOCAL VMG_UVAR
+        VMG_COMPAT_ARRAY_PUSH_NOLEN  VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID
+        VMG_COMPAT_ARRAY_UNDEF_CLEAR VMG_COMPAT_SCALAR_LENGTH_NOLEN
+        VMG_PERL_PATCHLEVEL
+        VMG_THREADSAFE
+        VMG_OP_INFO_NAME VMG_OP_INFO_OBJECT/) {
  eval { Variable::Magic->import($_) };
  is($@, '', 'import ' . $_);
 }

diff --git a/t/10-simple.t b/t/10-simple.t
index 1fdefcd61aa3e8b418e9863eecf5cd38b0b2b229..adfea124616eeebaa062560a617af581b76df62a 100644 (file)
--- a/t/10-simple.t
+++ b/t/10-simple.t
@@ -7,7 +7,7 @@ use Test::More tests => 46;
 
 use Variable::Magic qw/wizard gensig getsig cast dispell MGf_COPY MGf_DUP MGf_LOCAL VMG_UVAR/;
 
-my $args = 7;
+my $args = 8;
 ++$args if MGf_COPY;
 ++$args if MGf_DUP;
 ++$args if MGf_LOCAL;

diff --git a/t/14-callbacks.t b/t/14-callbacks.t
index e14d5709be01f2da446d27caadf1b663daff5176..eae92fd0ac60c4d27bb899d18242ae56a7d17ca2 100644 (file)
--- a/t/14-callbacks.t
+++ b/t/14-callbacks.t
@@ -3,9 +3,9 @@
 use strict;
 use warnings;
 
-use Test::More tests => 12;
+use Test::More tests => 12 + (2 * 5 + 2 * 6 + 2 * 5);
 
-use Variable::Magic qw/wizard cast/;
+use Variable::Magic qw/wizard cast dispell VMG_OP_INFO_NAME VMG_OP_INFO_OBJECT/;
 
 my $wiz = eval { wizard get => sub { undef } };
 is($@, '',             'wizard creation doesn\'t croak');
@@ -64,3 +64,40 @@ is($@, '', 'caller into callback doesn\'t croak');
 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' ]) {
+ my ($key, $var, $exp) = @$_;
+
+ for my $op_info (VMG_OP_INFO_NAME, VMG_OP_INFO_OBJECT, 3) {
+  my ($c, @c);
+
+  # We must test for the $op correctness inside the callback because, if we
+  # bring it out, it will go outside of the eval STRING scope, and what it
+  # points to will no longer exist.
+  eval {
+   $wiz = wizard $key => sub {
+    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";
+    } elsif ($op_info == 2) {
+     isa_ok $op, 'B::OP', $desc;
+     is $op->name, $exp, "$desc gets the right op info";
+    } else {
+     is $op, undef, "$desc gets the right op info";
+    }
+    ()
+   }, op_info => $op_info
+  };
+  is $@, '', "$key wizard with op_info == $op_info doesn't croak";
+
+  eval "cast $var, \$wiz";
+  is $@, '', "$key cast with op_info == $op_info doesn't croak";
+
+  eval "my \$x = $var";
+  is $@, '', "$key magic with op_info == $op_info doesn't croak";
+
+  eval "dispell $var, \$wiz";
+  is $@, '', "$key dispell with op_info == $op_info doesn't croak";
+ }
+}