diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | regcomp.c | 9 | ||||
| -rw-r--r-- | t/re/stclass_threads.t | 81 |
3 files changed, 91 insertions, 0 deletions
@@ -6216,6 +6216,7 @@ t/re/rxcode.t See if /(?{ code })/ works t/re/script_run.t See if script runs works t/re/speed.t See if optimisations are keeping things fast t/re/speed_thr.t ditto under threads +t/re/stclass_threads.t Test if stclass is preserved across threads t/re/subst.t See if substitution works t/re/subst_amp.t See if $&-related substitution works t/re/subst_wamp.t See if substitution works with $& present @@ -13436,6 +13436,15 @@ Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param) else reti->data = NULL; + if (ri->regstclass && !reti->regstclass) { + /* Assume that the regstclass is a regnode which is inside of the + * program which we have to copy over */ + regnode *node= ri->regstclass; + assert(node >= ri->program && (node - ri->program) < len); + reti->regstclass = reti->program + (node - ri->program); + } + + reti->name_list_idx = ri->name_list_idx; SetProgLen(reti, len); 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"); +} +# |