From: Vincent Pit <vince@profvince.com>
Date: Sat, 31 Mar 2012 14:51:52 +0000 (+0200)
Subject: Make sure the perl callback sample does not clobber PL_reg_state
X-Git-Tag: v0.02~4
X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=7eb360aa8aa4a3fbd88d6bf1dedd601e6dcef62e;p=perl%2Fmodules%2Fre-engine-Hooks.git

Make sure the perl callback sample does not clobber PL_reg_state

And add a test for this.
---

diff --git a/MANIFEST b/MANIFEST
index e81ec6d..7d0d4af 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -109,6 +109,7 @@ src/update.pl
 t/00-load.t
 t/05-keys.t
 t/10-base.t
+t/11-call-perl.t
 t/20-multi.t
 t/91-pod.t
 t/92-pod-coverage.t
diff --git a/t/11-call-perl.t b/t/11-call-perl.t
new file mode 100644
index 0000000..d600d32
--- /dev/null
+++ b/t/11-call-perl.t
@@ -0,0 +1,50 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+use blib 't/re-engine-Hooks-TestDist';
+
+use Test::More tests => 2 * 2;
+
+# Those tests must be ran inside eval STRING because the test distribution
+# can hold only one callback at a time.
+
+my @nodes;
+
+eval <<'TEST1';
+my $rx = do {
+ use re::engine::Hooks::TestDist 'custom' => sub { push @nodes, @_ };
+ qr/.(?:a|o).*/;
+};
+
+{
+ local $@;
+ eval {
+  "foo" =~ $rx;
+ };
+ is $@, '', 'calling perl code in the exec hook does not croak';
+ is_deeply \@nodes, [ qw<REG_ANY TRIE STAR END> ],
+            'calling perl code in the exec hook works correctly';
+}
+TEST1
+die $@ if $@;
+
+eval <<'TEST2';
+my $res;
+
+my $rx = do {
+ use re::engine::Hooks::TestDist 'custom' => sub { $res += ("durp" =~ /.urp/) };
+ qr/.(?:a|o).*/;
+};
+
+{
+ local $@;
+ eval {
+  "foo" =~ $rx;
+ };
+ is $@, '', 'a regexp match in the exec hook does not croak';
+ is $res, scalar(@nodes), 'a regexp match in the exec hook works correctly';
+}
+TEST2
+die $@ if $@;
diff --git a/t/re-engine-Hooks-TestDist/TestDist.xs b/t/re-engine-Hooks-TestDist/TestDist.xs
index 0005b01..ef36ccb 100644
--- a/t/re-engine-Hooks-TestDist/TestDist.xs
+++ b/t/re-engine-Hooks-TestDist/TestDist.xs
@@ -48,6 +48,8 @@ STATIC void reht_custom_comp_node(pTHX_ regexp *rx, regnode *node) {
  node_name = PL_reg_name[OP(node)];
 }
 
+STATIC struct re_save_state reht_state_bak;
+
 STATIC void reht_custom_exec_node(pTHX_ regexp *rx, regnode *node, regmatch_info *reginfo, regmatch_state *st) {
  STRLEN      node_namelen;
  const char *node_name;
@@ -55,6 +57,10 @@ STATIC void reht_custom_exec_node(pTHX_ regexp *rx, regnode *node, regmatch_info
  node_name    = PL_reg_name[OP(node)];
  node_namelen = strlen(node_name);
 
+ /* The global regexp state may be overwritten if the Perl callback does a
+  * regexp match. */
+ reht_state_bak = PL_reg_state;
+
  dSP;
 
  ENTER;
@@ -69,6 +75,8 @@ STATIC void reht_custom_exec_node(pTHX_ regexp *rx, regnode *node, regmatch_info
 
  FREETMPS;
  LEAVE;
+
+ PL_reg_state = reht_state_bak;
 }
 
 /* --- XS ------------------------------------------------------------------ */