regcomp.c - in regdupe_internal() set up "in program" stclass properly

We were only handling "synthetic start classes", not ones that are in
the program itself, because those dont have an entry in the data array.
So after copying the program after ruling out that the regstclass is
synthetic we can assume that if its non-null it points into the program
itself, and simply set it up the copy accordingly.

Fixes https://github.com/Perl/perl5/issues/9373

1 files changed, 81 insertions, 0 deletions

diff --git a/t/re/stclass_threads.t b/t/re/stclass_threads.t
new file mode 100644
index 0000000000..c55515aa40
--- /dev/null
+++ b/t/re/stclass_threads.t
@@ -0,0 +1,81 @@
+#!./perl
+#
+# This is a home for regular expression tests that don't fit into
+# the format supported by re/regexp.t.  If you want to add a test
+# that does fit that format, add it to re/re_tests, not here.
+
+use strict;
+use warnings;
+
+sub run_tests;
+
+$| = 1;
+
+BEGIN {
+    chdir 't' if -d 't';
+    require './test.pl';
+    set_up_inc('../lib', '.', '../ext/re');
+    require Config; import Config;
+}
+
+skip_all_without_config('useithreads');
+skip_all_if_miniperl("no dynamic loading on miniperl, no threads");
+
+plan tests => 6;  # Update this when adding/deleting tests.
+
+run_tests() unless caller;
+
+#
+# Tests start here.
+#
+sub run_tests {
+    my @res;
+    for my $len (10,100,1000) {
+        my $result1= fresh_perl(sprintf(<<'EOF_CODE', $len),
+        use threads;
+        use re 'debug';
+
+        sub start_thread {
+            warn "===\n";
+            split /[.;]+[\'\"]+/, $_[0];
+            warn "===\n";
+        }
+
+        my $buffer = '.' x %d;
+
+        start_thread $buffer;
+EOF_CODE
+        {});
+        my $result2= fresh_perl(sprintf(<<'EOF_CODE', $len),
+        use threads;
+        use re 'debug';
+
+        sub start_thread {
+            warn "\n===\n";
+            split /[.;]+[\'\"]+/, $_[0];
+            warn "\n===\n";
+        }
+
+        my $buffer = '.' x %d;
+        my $thr = threads->create('start_thread', $buffer);
+        $thr->join();
+EOF_CODE
+        {});
+        for ($result1, $result2) {
+            (undef,$_,undef)= split /\n===\n/, $_;
+        }
+        my @l1= split /\n/, $result1;
+        my @l2= split /\n/, $result2;
+        push @res, 0+@l2;
+        is(0+@l2,0+@l1, sprintf
+            "Threaded and unthreaded stclass behavior matches (n=%d)",
+            $len);
+    }
+    my $n10= $res[0]/10;
+    my $n100= $res[1]/100;
+    my $n1000= $res[2]/1000;
+    ok(abs($n10-$n100)<1,"Behavior appears to be sub quadratic ($n10, $n100)");
+    ok(abs($n100-$n1000)<0.1,"Behavior is linear and not quadratic ($n100, $n1000)");
+    ok(abs(3-$n1000)<0.1,"Behavior is linear as expected");
+}
+#