Add support for the check hook and test multiple keywords

diff --git a/Op.xs b/Op.xs
index 490dc2d77addcdab4d360e0d3685d4e366762584..5c9413b18afdeb95f7e69f654532d2649d45ee15 100644 (file)
--- a/Op.xs
+++ b/Op.xs
@@ -107,6 +107,12 @@ void sub_op_register(pTHX_ const sub_op_keyword *k) {
   PL_custom_op_descs = newHV();
  (void) hv_store_ent(PL_custom_op_descs, key, newSVpv(k->name, k->len), 0);
 
+ if (k->check) {
+  SV *check = newSViv(PTR2IV(k->check));
+  sv_magicext(key, check, PERL_MAGIC_ext, NULL, k->ud, 0);
+  SvREFCNT_dec(check);
+ }
+
  {
   dMY_CXT;
   (void) hv_store(MY_CXT.map, k->name, k->len, key, 0);
@@ -267,6 +273,14 @@ STATIC OP *sub_op_ck_entersub(pTHX_ OP *o) {
       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);
     }
    }

diff --git a/lib/Sub/Op.pm b/lib/Sub/Op.pm
index dbcdcd2a46ff0582efb085169afdacbc92a50198..a7ad9f9cbd8081eb8fa66833516d5f6bbac6bce5 100644 (file)
--- a/lib/Sub/Op.pm
+++ b/lib/Sub/Op.pm
@@ -52,8 +52,9 @@ In your XS file :
      sub_op_keyword k;
      k.name  = "reftype";
      k.len   = sizeof("reftype")-1;
-     k.check = 0;
      k.pp    = scalar_util_reftype;
+     k.check = 0;
+     k.ud    = NULL;
      sub_op_register(aTHX_ &k);
     }
 

diff --git a/sub_op.h b/sub_op.h
index 161d147f80549bb5d6c6f2a5a9255198e104c4f9..c7fc83f0e9240e1c3fa8e5e3650bfd9e703c0e4b 100644 (file)
--- a/sub_op.h
+++ b/sub_op.h
@@ -4,11 +4,14 @@
 #ifndef SUB_OP_H
 #define SUB_OP_H 1
 
+typedef OP *(*sub_op_check_t)(pTHX_ OP *, void *);
+
 typedef struct {
- const char   *name;
- STRLEN        len;
- Perl_ppaddr_t pp;
- void        (*check)(pTHX_ OP *);
+ const char    *name;
+ STRLEN         len;
+ Perl_ppaddr_t  pp;
+ sub_op_check_t check;
+ void          *ud;
 } sub_op_keyword;
 
 void sub_op_register(pTHX_ const sub_op_keyword *k);

diff --git a/t/10-base.t b/t/10-base.t
index 86042b35120bd42d58cf9455291c36a836987844..891a8cbc693669dca37055f1c77b5f1b2449f078 100644 (file)
--- a/t/10-base.t
+++ b/t/10-base.t
@@ -5,49 +5,66 @@ use warnings;
 
 use blib 't/Sub-Op-Test';
 
-use Test::More tests => 2 * 15 + 21;
+use Test::More tests => 2 * 15 + 3 * 1 + 2 * 23;
 
 our $called;
 
 {
  local $/ = "####\n";
  while (<DATA>) {
-  my ($code, $params)    = split /----\s*/, $_;
-  my ($name, $ret, $exp) = split /\s*#\s*/, $params;
+  my ($code, $params)           = split /----\s*/, $_;
+  my ($names, $ret, $exp, $seq) = split /\s*#\s*/, $params;
+
+  my @names = split /\s*,\s*/, $names;
 
   my @exp = eval $exp;
   if ($@) {
-   fail "unable to get expected values: $@";
+   fail "@names: unable to get expected values: $@";
    next;
   }
   my $calls = @exp;
 
-  $code = <<"  WRAPPER";
-  {
-   use Sub::Op::Test $name => sub {
-    ++\$called;
-    my \$exp = shift \@exp;
-    is_deeply \\\@_, \$exp, '$name: arguments are correct';
-    $ret;
-   };
-   {
-    $code
-   }
-   BEGIN {
-    no warnings 'uninitialized'; # Test::Builder can't get the file name
-    is *main::${name}{CODE}, undef, '$name: no symbol table vivification';
-   }
+  my @seq;
+  if ($seq) {
+   s/^\s*//, s/\s*$//  for $seq;
+   @seq = split /\s*,\s*/, $seq;
+   die "calls and seq length mismatch" unless @seq == $calls;
+  } else {
+   @seq = ($names[0]) x $calls;
+  }
+
+  my $test = "{\n";
+  for my $name (@names) {
+   $test .= <<"   INIT"
+    use Sub::Op::Test $name => sub {
+     ++\$called;
+     my \$exp = shift \@exp;
+     is_deeply \\\@_, \$exp,   '$name: arguments are correct';
+     my \$seq = shift \@seq;
+     is        \$seq, '$name', '$name: sequence is correct';
+     $ret;
+    };
+   INIT
   }
-  WRAPPER
+  $test .= "{\n$code\n}\n";
+  for my $name (@names) {
+   $test .= <<"   CHECK_VIVID"
+    BEGIN {
+     no warnings 'uninitialized'; # Test::Builder can't get the file name
+     is *main::${name}\{CODE\}, undef, '$name: no symbol table vivification';
+    }
+   CHECK_VIVID
+  }
+  $test .= "}\n";
 
   local $called = 0;
-  eval $code;
+  eval $test;
   if ($@) {
-   fail "$name: unable to evaluate test case: $@";
-   diag $code;
+   fail "@names: unable to evaluate test case: $@";
+   diag $test;
   }
 
-  is $called, $calls, "$name: the hook was called the right number of times";
+  is $called, $calls, "@names: the hook was called the right number of times";
   if ($called < $calls) {
    fail for $called + 1 .. $calls;
   }
@@ -120,3 +137,8 @@ our %hash = (x => 4);
 hash $hash{x};
 ----
 hash # () # [ 4 ]
+####
+foo 1;
+bar 2;
+----
+foo, bar # () # [ 1 ], [ 2 ] # foo, bar

diff --git a/t/Sub-Op-Test/Test.xs b/t/Sub-Op-Test/Test.xs
index 4750507ad9ce45eb3ba3ed46d0c600d50987cafb..b3179698622f1592fcfe6c1ba5562ceca965bdc6 100644 (file)
--- a/t/Sub-Op-Test/Test.xs
+++ b/t/Sub-Op-Test/Test.xs
@@ -11,19 +11,38 @@
 
 #include "sub_op.h"
 
-STATIC SV *sub_op_test_cb = NULL;
+STATIC HV *sub_op_test_map = NULL;
+
+STATIC OP *sub_op_test_check(pTHX_ OP *o, void *ud_) {
+ char buf[sizeof(void*)*2+1];
+ SV *cb = ud_;
+
+ (void) hv_store(sub_op_test_map, buf, sprintf(buf, "%"UVxf, PTR2UV(o)), cb, 0);
+
+ return o;
+}
 
 STATIC OP *sub_op_test_pp(pTHX) {
  dSP;
  dMARK;
+ SV *cb;
  int i, items;
 
+ {
+  char buf[sizeof(void*)*2+1];
+  SV **svp;
+  svp = hv_fetch(sub_op_test_map, buf, sprintf(buf, "%"UVxf, PTR2UV(PL_op)), 0);
+  if (!svp)
+   RETURN;
+  cb = *svp;
+ }
+
  ENTER;
  SAVETMPS;
 
  PUSHMARK(MARK);
 
- items = call_sv(sub_op_test_cb, G_ARRAY);
+ items = call_sv(cb, G_ARRAY);
 
  SPAGAIN;
  for (i = 0; i < items; ++i)
@@ -42,27 +61,25 @@ MODULE = Sub::Op::Test      PACKAGE = Sub::Op::Test
 
 PROTOTYPES: ENABLE
 
+BOOT:
+{
+ sub_op_test_map = newHV();
+}
+
 void
-_init(SV *name)
-PROTOTYPE: $
+_init(SV *name, SV *cb)
+PROTOTYPE: $$
 PREINIT:
  sub_op_keyword k;
-PPCODE:
- k.name  = SvPV_const(name, k.len);
- k.check = 0;
- k.pp    = sub_op_test_pp;
- sub_op_register(aTHX_ &k);
- XSRETURN(0);
-
-void
-_callback(SV *cb)
-PROTOTYPE: $
 PPCODE:
  if (SvROK(cb)) {
   cb = SvRV(cb);
   if (SvTYPE(cb) >= SVt_PVCV) {
-   SvREFCNT_dec(sub_op_test_cb);
-   sub_op_test_cb = SvREFCNT_inc(cb);
+   k.name  = SvPV_const(name, k.len);
+   k.check = sub_op_test_check;
+   k.ud    = SvREFCNT_inc(cb);
+   k.pp    = sub_op_test_pp;
+   sub_op_register(aTHX_ &k);
   }
  }
  XSRETURN(0);

diff --git a/t/Sub-Op-Test/lib/Sub/Op/Test.pm b/t/Sub-Op-Test/lib/Sub/Op/Test.pm
index a8bd2bfe098e26427e84e77cb086fc4ac05faaaf..ad379a3e76e7542dfc90d9b9d5f5a0ceafbc83e7 100644 (file)
--- a/t/Sub-Op-Test/lib/Sub/Op/Test.pm
+++ b/t/Sub-Op-Test/lib/Sub/Op/Test.pm
@@ -19,8 +19,7 @@ sub import {
 
  my ($name, $cb) = @_;
 
- _init($name);
- _callback($cb);
+ _init($name, $cb);
 
  Sub::Op::enable($name => scalar caller);
 }