Add test against re-eval corrupting regexp state

1 files changed, 85 insertions, 0 deletions

diff --git a/t/re/reg_eval.t b/t/re/reg_eval.t
new file mode 100644
index 0000000000..56a55a8d85
--- /dev/null
+++ b/t/re/reg_eval.t
@@ -0,0 +1,85 @@
+#!./perl
+
+# This is a test for bugs in (?{ }) and (??{ }) caused by corrupting the regex
+# engine state within the eval-ed code
+# --rafl
+
+BEGIN {
+    require './test.pl';
+}
+
+fresh_perl_is(<<'CODE', 'ok', {});
+'42' =~ /4(?{ 'foo' =~ m{(foo)} })2/
+    and print 'ok';
+CODE
+
+fresh_perl_is(<<'CODE', 'ok', {}, 'RT#33936');
+'aba' =~ /(??{join('',split(qr{(?=)},'aba'))})/
+    and print 'ok';
+CODE
+
+fresh_perl_is(<<'CODE', 'ok', {}, 'match vars are localized');
+my $x = 'aba';
+$x =~ s/(a)(?{ 'moo' =~ m{(o)} })/uc($1)/e;
+print 'ok' if $x eq 'Aba';
+CODE
+
+my $preamble = <<'CODE';
+sub build_obj {
+  # In the real world we would die on validation fails, but RT#27838
+  # is still unresolved, so don't tempt fate.
+  $hash->{name} =~ /^[A-Z][a-z]+ [A-Z][a-z]+$/ or return "name error";
+  $hash->{age} =~ /^[1-9][0-9]*$/ or return "age error";
+
+  # Add another layer of (?{...}) to try really hard to break things
+  $hash->{square} =~
+  /^(\d+)(?(?{my $sqrt = sprintf "%.0f", sqrt($^N); $sqrt**2==$^N })|(?!))$/
+  or return "squareness error";
+
+  return bless { %$hash }, "Foo";
+}
+
+sub match {
+  my $str = shift;
+  our ($hash, $obj);
+  # Do something like Regexp::Grammars does building an object.
+  my $matched = $str =~ /
+    ()
+    ([A-Za-z][A-Za-z ]*)(?{ local $hash->{name} = $^N }),[ ]
+    (\d+)(?{ local $hash->{age} = $^N })[ ]years[ ]old,[ ]
+    secret[ ]number[ ](\d+)(?{ local $hash->{square} = $^N }).
+    (?{ $obj = build_obj(); })
+  /x;
+
+  if ($matched) {
+    print "match ";
+    if (ref($obj)) {
+      print ref($obj), ":$obj->{name}:$obj->{age}:$obj->{square}";
+    } else {
+      print $obj, ":$hash->{name}:$hash->{age}:$hash->{square}";
+    }
+  } else {
+    print "no match $hash->{name}:$hash->{age}:$hash->{square}";
+  }
+
+}
+CODE
+
+fresh_perl_is($preamble . <<'CODE', 'match Foo:John Smith:42:36', {}, 'regex distillation 1');
+match("John Smith, 42 years old, secret number 36.");
+CODE
+
+fresh_perl_is($preamble . <<'CODE', 'match Foo:John Smith:42:36', {}, 'regex distillation 2');
+match("Jim Jones, 35 years old, secret wombat 007."
+  ." John Smith, 42 years old, secret number 36.");
+CODE
+
+fresh_perl_is($preamble . <<'CODE', 'match squareness error:::', {}, 'regex distillation 3');
+match("John Smith, 54 years old, secret number 7.");
+CODE
+
+fresh_perl_is($preamble . <<'CODE', 'no match ::', {}, 'regex distillation 4');
+match("Jim Jones, 35 years old, secret wombat 007.");
+CODE
+
+done_testing;