Introduce ->callbacks to specify the 'exec' callback individually

diff --git a/MANIFEST b/MANIFEST
index 1380013cb318575d3e4ee2081c8a157e792676e7..51e2b215f0f0d961157507abfc1297dff1d10dba 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -10,6 +10,7 @@ Plugin.xs
 README
 ptable.h
 t/00-compile.t
+t/callbacks/exec.t
 t/eval-comp.t
 t/eval-exec.t
 t/import.t

diff --git a/Plugin.pm b/Plugin.pm
index ef2dbaea34c38939567c31373fb19bd94c5659ef..2177dfdacecae5948b5fe722bc5229932d4991c1 100644 (file)
--- a/Plugin.pm
+++ b/Plugin.pm
@@ -51,6 +51,19 @@ sub unimport
     return;
 }
 
+sub callbacks
+{
+    my ($re, %callback) = @_;
+
+    my %map = map { $_ => "_$_" } qw/exec/;
+
+    for my $key (keys %callback) {
+        my $name = $map{$key};
+        next unless defined $name;
+        $re->$name($callback{$key});
+    }
+}
+
 sub num_captures
 {
     my ($re, %callback) = @_;

diff --git a/Plugin.pod b/Plugin.pod
index 137199c10c43926c405946dadc26544a6a7065d6..7fda6f78d2fa14303d51db1ed580d964d7ecde9f 100644 (file)
--- a/Plugin.pod
+++ b/Plugin.pod
@@ -122,6 +122,9 @@ available as the second argument (C<$str>) and through the L<str|/str>
 method. The routine should return a true value if the match was
 successful, and a false one if it wasn't.
 
+This callback can also be specified on an individual basis with the
+L</callbacks> method.
+
 =head1 METHODS
 
 =head2 str
@@ -182,6 +185,29 @@ called at all.
 The length specified will be used as a a byte length (using
 L<SvPV|perlapi/SvPV>), not a character length.
 
+=head2 callbacks
+
+    # A dumb regexp engine that just tests string equality
+    use re::engine::Plugin comp => sub {
+        my ($re) = @_;
+
+        my $pat = $re->pattern;
+
+        $re->callbacks(
+            exec => sub {
+                my ($re, $str) = @_;
+                return $pat eq $str;
+            },
+        );
+    };
+
+Takes a list of key-value pairs of names and subroutines, and replace the
+callback currently attached to the regular expression for the type given as
+the key by the code reference passed as the corresponding value.
+
+The only valid key is currently C<exec>. See L</exec> for more details about
+this callback.
+
 =head2 num_captures
 
     $re->num_captures(

diff --git a/Plugin.xs b/Plugin.xs
index fab9308b839fabca90018f5f5adf9e1b292a8bc9..3abd900c12e2a74beaa3d6795028307c44fe0160 100644 (file)
--- a/Plugin.xs
+++ b/Plugin.xs
@@ -768,6 +768,15 @@ PPCODE:
         }
     }
 
+void
+_exec(re::engine::Plugin self, ...)
+PPCODE:
+    if (items > 1) {
+        SvREFCNT_dec(self->cb_exec);
+        self->cb_exec = ST(1);
+        SvREFCNT_inc(self->cb_exec);
+    }
+
 void
 _num_capture_buff_FETCH(re::engine::Plugin self, ...)
 PPCODE:

diff --git a/t/callbacks/exec.t b/t/callbacks/exec.t
new file mode 100644 (file)
index 0000000..d340ffe
--- /dev/null
+++ b/t/callbacks/exec.t
@@ -0,0 +1,38 @@
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 4 * 2;
+
+my $count;
+
+use re::engine::Plugin comp => sub {
+ my ($re) = @_;
+
+ my $pat = $re->pattern;
+
+ $re->callbacks(
+  exec => sub {
+   my ($re, $str) = @_;
+
+   ++$count;
+
+   return $str eq $pat;
+  },
+ );
+};
+
+$count = 0;
+
+ok "foo"  =~ /foo/;
+is $count, 1;
+ok "fool" !~ /foo/;
+is $count, 2;
+
+my $rx = qr/bar/;
+
+ok "bar"  =~ $rx;
+is $count, 3;
+ok "foo"  !~ $rx;
+is $count, 4;