Variants of several regression tests that run the actul tests inside
authorNicholas Clark <nick@ccl4.org>
Wed, 9 Jan 2008 22:42:04 +0000 (22:42 +0000)
committerNicholas Clark <nick@ccl4.org>
Wed, 9 Jan 2008 22:42:04 +0000 (22:42 +0000)
a new thread, to test ithread's cloning, particularly of regexps.

p4raw-id: //depot/perl@32931

13 files changed:
MANIFEST
t/op/index.t
t/op/index_thr.t [new file with mode: 0644]
t/op/pat.t
t/op/pat_thr.t [new file with mode: 0644]
t/op/re_tests
t/op/reg_email.t
t/op/reg_email_thr.t [new file with mode: 0644]
t/op/regexp.t
t/op/regexp_qr_embed_thr.t [new file with mode: 0644]
t/op/substr.t
t/op/substr_thr.t [new file with mode: 0644]
t/thread_it.pl [new file with mode: 0644]

index d09923c..91a450f 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -3841,6 +3841,7 @@ t/op/inccode-tie.t                See if tie to @INC works
 t/op/incfilter.t               See if the source filters in coderef-in-@INC work
 t/op/inc.t                     See if inc/dec of integers near 32 bit limit work
 t/op/index.t                   See if index works
+t/op/index_thr.t               See if index works in another thread
 t/op/int.t                     See if int works
 t/op/join.t                    See if join works
 t/op/kill0.t                   See if kill(0, $pid) works
@@ -3870,6 +3871,7 @@ t/op/overload_integer.t                   See if overload::constant for integer works after "use
 t/op/override.t                        See if operator overriding works
 t/op/pack.t                    See if pack and unpack work
 t/op/pat.t                     See if esoteric patterns work
+t/op/pat_thr.t                 See if esoteric patterns work in another thread
 t/op/pos.t                     See if pos works
 t/op/pow.t                     See if ** works
 t/op/push.t                    See if push and pop work
@@ -3886,9 +3888,11 @@ t/op/read.t                      See if read() works
 t/op/recurse.t                 See if deep recursion works
 t/op/ref.t                     See if refs and objects work
 t/op/reg_email.t               See if regex recursion works by parsing email addresses
+t/op/reg_email_thr.t           See if regex recursion works by parsing email addresses in another thread
 t/op/regexp_noamp.t            See if regular expressions work with optimizations
 t/op/regexp_notrie.t           See if regular expressions work without trie optimisation
 t/op/regexp_qr_embed.t         See if regular expressions work with embedded qr//
+t/op/regexp_qr_embed_thr.t     See if regular expressions work with embedded qr// in another thread
 t/op/regexp_qr.t               See if regular expressions work as qr//
 t/op/regexp.t                  See if regular expressions work
 t/op/regexp_trielist.t         See if regular expressions work with trie optimisation
@@ -3922,6 +3926,7 @@ t/op/studytied.t          See if study works with tied scalars
 t/op/sub_lval.t                        See if lvalue subroutines work
 t/op/subst_amp.t               See if $&-related substitution works
 t/op/substr.t                  See if substr works
+t/op/substr_thr.t              See if substr works in another thread
 t/op/subst.t                   See if substitution works
 t/op/substT.t                  See if substitution works with -T
 t/op/subst_wamp.t              See if substitution works with $& present
@@ -4011,6 +4016,7 @@ t/run/switchx.t                   Test the -x switch
 t/TEST                         The regression tester
 t/TestInit.pm                  Preamble library for core tests
 t/test.pl                      Simple testing library
+t/thread_it.pl                 Run regression tests in a new thread
 t/uni/cache.t                  See if Unicode swash caching works
 t/uni/case.pl                  See if Unicode casing works
 t/uni/chomp.t                  See if Unicode chomp works
index b384bef..38da96c 100755 (executable)
@@ -9,6 +9,10 @@ BEGIN {
 use strict;
 plan( tests => 69 );
 
+run_tests() unless caller;
+
+sub run_tests {
+
 my $foo = 'Now is the time for all good men to come to the aid of their country.';
 
 my $first = substr($foo,0,index($foo,'the'));
@@ -155,3 +159,5 @@ SKIP: {
     local ${^UTF8CACHE} = -1;
     is(index($t, 'xyz'), 4, "0xfffffffd and utf8cache");
 }
+
+}
diff --git a/t/op/index_thr.t b/t/op/index_thr.t
new file mode 100644 (file)
index 0000000..3a97741
--- /dev/null
@@ -0,0 +1,7 @@
+#!./perl
+
+chdir 't' if -d 't';
+@INC = ('../lib', '.');
+
+require 'thread_it.pl';
+thread_it(qw(op index.t));
index 0e16cd9..2ccc07c 100755 (executable)
@@ -16,6 +16,10 @@ our $Message = "Noname test";
 
 eval 'use Config';          #  Defaults assumed if this fails
 
+run_tests() unless caller;
+
+sub run_tests {
+
 $x = "abc\ndef\n";
 
 if ($x =~ /^abc/) {print "ok 1\n";} else {print "not ok 1\n";}
@@ -533,25 +537,32 @@ print "not " unless $1 and /$1/;
 print "ok $test\n";
 $test++;
 
+if ($::running_as_thread) {
+    print "not ok $test # TODO & SKIP: croaks in 5.10 when threaded\n";
+    $test++;
+} else {
 $a=qr/(?{++$b})/;
 $b = 7;
 /$a$a/;
 print "not " unless $b eq '9';
 print "ok $test\n";
 $test++;
+}
 
-$c="$a";
-/$a$a/;
-print "not " unless $b eq '11';
-print "ok $test\n";
-$test++;
+{
+    local $TODO = $::running_as_thread;
+    $c="$a";
+    /$a$a/;
+    iseq($b, '11');
+}
 
 {
   use re "eval";
   /$a$c$a/;
-  print "not " unless $b eq '14';
-  print "ok $test\n";
-  $test++;
+  {
+      local $TODO = $::running_as_thread;
+      iseq($b, '14');
+  }
 
   local $lex_a = 2;
   my $lex_a = 43;
@@ -571,10 +582,10 @@ $test++;
 
   no re "eval";
   $match = eval { /$a$c$a/ };
-  print "not "
-    unless $b eq '14' and $@ =~ /Eval-group not allowed/ and not $match;
-  print "ok $test\n";
-  $test++;
+  # FIXME - split this one. That would require removing a lot of hard coded
+  # test numbers.
+  local $TODO = $::running_as_thread;
+  ok($b eq '14' and $@ =~ /Eval-group not allowed/ and not $match);
 }
 
 {
@@ -789,9 +800,10 @@ print "not " if $str =~ /^...\G/;
 print "ok $test\n";
 $test++;
 
-print "not " unless $str =~ /.\G./ and $& eq 'bc';
-print "ok $test\n";
-$test++;
+{
+    local $TODO = $::running_as_thread;
+    ok($str =~ /.\G./ and $& eq 'bc');
+}
 
 print "not " unless $str =~ /\G../ and $& eq 'cd';
 print "ok $test\n";
@@ -875,23 +887,29 @@ $foo='aabbccddeeffgg';
 pos($foo)=1;
 
 $foo=~/.\G(..)/g;
-iseq($1,'ab');
+{
+    local $TODO = $::running_as_thread;
+    iseq($1,'ab');
+}
 
 pos($foo) += 1;
 $foo=~/.\G(..)/g;
-print "not " unless($1 eq 'cc');
-print "ok $test\n";
-$test++;
+{
+    local $TODO = $::running_as_thread;
+    iseq($1, 'cc');
+}
 
 pos($foo) += 1;
 $foo=~/.\G(..)/g;
-print "not " unless($1 eq 'de');
-print "ok $test\n";
-$test++;
+{
+    local $TODO = $::running_as_thread;
+    iseq($1, 'de');
+}
 
-print "not " unless $foo =~ /\Gef/g;
-print "ok $test\n";
-$test++;
+{
+    local $TODO = $::running_as_thread;
+    ok($foo =~ /\Gef/g);
+}
 
 undef pos $foo;
 
@@ -1279,7 +1297,10 @@ print "ok 246\n";
 print "not " unless "\x{abcd}" =~ /\x{abcd}/;
 print "ok 247\n";
 
-{
+if ($::running_as_thread) {
+    print "not ok 248 # TODO & SKIP: SEGVs in 5.10 when threaded\n";
+    print "not ok 249 # TODO & SKIP: SEGVs in 5.10 when threaded\n";
+} else {
     # bug id 20001008.001
 
     $test = 248;
@@ -4525,7 +4546,12 @@ sub kt
      s/(*:X)A+|(*:Y)B+|(*:Z)C+/$REGMARK/g;
      iseq $_, "ZYX";
 }
-{
+if ($::running_as_thread) {
+    for (1..3) {
+       print "not ok $test # TODO & SKIP: croaks when threaded\n";
+       $test++;
+    }
+} else {
     our @ctl_n=();
     our @plus=();
     our $nested_tags;
@@ -4606,8 +4632,13 @@ ok($@=~/\QSequence \k... not terminated in regex;\E/);
 
 # Put new tests above the dotted line about a page above this comment
 iseq(0+$::test,$::TestCount,"Got the right number of tests!");
+
+} # end of sub pat_tests
+
 # Don't forget to update this!
 BEGIN {
     $::TestCount = 4019;
     print "1..$::TestCount\n";
 }
+
+"Truth";
diff --git a/t/op/pat_thr.t b/t/op/pat_thr.t
new file mode 100644 (file)
index 0000000..3228b33
--- /dev/null
@@ -0,0 +1,7 @@
+#!./perl
+
+chdir 't' if -d 't';
+@INC = ('../lib', '.');
+
+require 'thread_it.pl';
+thread_it(qw(op pat.t));
index c2397e6..6f4db07 100644 (file)
@@ -503,14 +503,14 @@ a(?:b|(c|e){1,2}?|d)+?(.) ace     y       $1$2    ce
 '(ab)\d\1'i    Ab4ab   y       $1      Ab
 '(ab)\d\1'i    ab4Ab   y       $1      ab
 foo\w*\d{4}baz foobar1234baz   y       $&      foobar1234baz
-a(?{})b        cabd    y       $&      ab
+a(?{})b        cabd    yt      $&      ab      threads confuse eval
 a(?{)b -       c       -       Sequence (?{...}) not terminated or not {}-balanced
 a(?{{})b       -       c       -       Sequence (?{...}) not terminated or not {}-balanced
 a(?{}})b       -       c       -       
 a(?{"{"})b     -       c       -       Sequence (?{...}) not terminated or not {}-balanced
-a(?{"\{"})b    cabd    y       $&      ab
+a(?{"\{"})b    cabd    yt      $&      ab      threads confuse eval
 a(?{"{"}})b    -       c       -       Unmatched right curly bracket
-a(?{$::bl="\{"}).b     caxbd   y       $::bl   {
+a(?{$::bl="\{"}).b     caxbd   yt      $::bl   {       threads confuse eval
 x(~~)*(?:(?:F)?)?      x~~     y       -       -
 ^a(?#xxx){3}c  aaac    y       $&      aaac
 '^a (?#xxx) (?#yyy) {3}c'x     aaac    y       $&      aaac
@@ -550,10 +550,10 @@ x(~~)*(?:(?:F)?)? x~~     y       -       -
 ^(\(+)?blah(?(1)(\)))$ (blah   n       -       -
 (?(1?)a|b)     a       c       -       Switch condition not recognized
 (?(1)a|b|c)    a       c       -       Switch (?(condition)... contains too many branches
-(?(?{0})a|b)   a       n       -       -
-(?(?{0})b|a)   a       y       $&      a
-(?(?{1})b|a)   a       n       -       -
-(?(?{1})a|b)   a       y       $&      a
+(?(?{0})a|b)   a       nt      -       -       threads confuse eval
+(?(?{0})b|a)   a       yt      $&      a       threads confuse eval
+(?(?{1})b|a)   a       nt      -       -       threads confuse eval
+(?(?{1})a|b)   a       yt      $&      a       threads confuse eval
 (?(?!a)a|b)    a       n       -       -
 (?(?!a)b|a)    a       y       $&      a
 (?(?=a)b|a)    a       n       -       -
@@ -573,8 +573,8 @@ $(?<=^(a))  a       y       $1      a
 ([\w:]+::)?(\w+)$      abcd    y       $1-$2   -abcd
 ([\w:]+::)?(\w+)$      xy:z:::abcd     y       $1-$2   xy:z:::-abcd
 ^[^bcd]*(c+)   aexycd  y       $1      c
-(?{$a=2})a*aa(?{local$a=$a+1})k*c(?{$b=$a})    yaaxxaaaacd     y       $b      3
-(?{$a=2})(a(?{local$a=$a+1}))*aak*c(?{$b=$a})  yaaxxaaaacd     y       $b      4
+(?{$a=2})a*aa(?{local$a=$a+1})k*c(?{$b=$a})    yaaxxaaaacd     yt      $b      3       threads confuse eval
+(?{$a=2})(a(?{local$a=$a+1}))*aak*c(?{$b=$a})  yaaxxaaaacd     yt      $b      4       threads confuse eval
 (>a+)ab        aaab    n       -       -
 (?>a+)b        aaab    y       -       -
 ([[:]+)        a:[b]:  y       $1      :[
@@ -817,7 +817,7 @@ abb$        b\nca   n       -       -
 'abb$'m        b\nca   n       -       -
 (^|x)(c)       ca      y       $2      c
 a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz   x       n       -       -
-a(?{$a=2;$b=3;($b)=$a})b       yabz    y       $b      2
+a(?{$a=2;$b=3;($b)=$a})b       yabz    yt      $b      2       threads confuse eval
 round\(((?>[^()]+))\)  _I(round(xs * sz),1)    y       $1      xs * sz
 '((?x:.) )'    x       y       $1-     x -
 '((?-x:.) )'x  x       y       $1-     x-
@@ -896,7 +896,7 @@ tt+$        xxxtt   y       -       -
 (abc)?(abc)+   abc     y       $1:$2   :abc    -
 'b\s^'m        a\nb\n  n       -       -
 \ba    a       y       -       -
-^(a(??{"(?!)"})|(a)(?{1}))b    ab      y       $2      a       # [ID 20010811.006]
+^(a(??{"(?!)"})|(a)(?{1}))b    ab      yt      $2      a       # [ID 20010811.006]     threads confuse eval
 ab(?i)cd       AbCd    n       -       -       # [ID 20010809.023]
 ab(?i)cd       abCd    y       -       -
 (A|B)*(?(1)(CD)|(CD))  CD      y       $2-$3   -CD
@@ -941,7 +941,7 @@ ab(?i)cd    abCd    y       -       -
 (.*?)(?<=[bc]) abcd    y       $1      ab
 (.*?)(?<=[bc])c        abcd    y       $1      ab
 2(]*)?$\1      2       y       $&      2
-(??{}) x       y       -       -
+(??{}) x       yt      -       -       threads confuse eval
 a(b)?? abc     y       <$1>    <>      # undef [perl #16773]
 (\d{1,3}\.){3,}        128.134.142.8   y       <$1>    <142.>  # [perl #18019]
 ^.{3,4}(.+)\1\z        foobarbar       y       $1      bar     # 16 tests for [perl #23171]
@@ -974,8 +974,8 @@ x(?#        x       c       -       Sequence (?#... not terminated
 (x.|foo|fool|x.|money|parted|y.)$      fools   n       -       -
 (foo|fool|money|parted)$       fools   n       -       -
 (a|aa|aaa||aaaa|aaaaa|aaaaaa)(b|c)     aaaaaaaaaaaaaaab        y       $1$2    aaaaaab
-(a|aa|aaa||aaaa|aaaaa|aaaaaa)(??{$1&&""})(b|c) aaaaaaaaaaaaaaab        y       $1$2    aaaaaab
-(a|aa|aaa|aaaa|aaaaa|aaaaaa)(??{$1&&"foo"})(b|c)       aaaaaaaaaaaaaaab        n       -       -
+(a|aa|aaa||aaaa|aaaaa|aaaaaa)(??{$1&&""})(b|c) aaaaaaaaaaaaaaab        yt      $1$2    aaaaaab threads confuse eval
+(a|aa|aaa|aaaa|aaaaa|aaaaaa)(??{$1&&"foo"})(b|c)       aaaaaaaaaaaaaaab        nt      -       -       threads confuse eval
 ^(a*?)(?!(aa|aaaa)*$)  aaaaaaaaaaaaaaaaaaaa    y       $1      a       # [perl #34195]
 ^(a*?)(?!(aa|aaaa)*$)(?=a\z)   aaaaaaaa        y       $1      aaaaaaa
 ^(.)\s+.$(?(1))        A B     y       $1      A       # [perl #37688]
@@ -1019,18 +1019,18 @@ X(?=foo)        ..XfooY..       y       pos     3
 X(?<=foo.)[YZ] ..XfooXY..      y       pos     8
 (?=XY*foo)     Xfoo    y       pos     0
 ^(?=XY*foo)    Xfoo    y       pos     0
-^(??{"a+"})a   aa      y       $&      aa
-^(?:(??{"a+"})|b)a     aa      y       $&      aa
-^(??{chr 0x100}).$     \x{100}\x{100}  y       $&      \x{100}\x{100}
-^(??{q(\x{100})}).     \x{100}\x{100}  y       $&      \x{100}\x{100}
-^(??{q(.+)})\x{100}    \x{100}\x{100}  y       $&      \x{100}\x{100}
-^(??{q(.)})\x{100}     \x{100}\x{100}  y       $&      \x{100}\x{100}
-^(??{chr 0x100})\xbb   \x{100}\x{bb}   y       $&      \x{100}\x{bb}
-^(.)(??{"(.)(.)"})(.)$ abcd    y       $1-$2   a-d
-^(.)(??{"(bz+|.)(.)"})(.)$     abcd    y       $1-$2   a-d
-^(.)((??{"(.)(cz+)"})|.)       abcd    y       $1-$2   a-b
-^a(?>(??{q(b)}))(??{q(c)})d    abcd    y       -       -
-^x(??{""})+$   x       y       $&      x
+^(??{"a+"})a   aa      yt      $&      aa      threads confuse eval
+^(?:(??{"a+"})|b)a     aa      yt      $&      aa      threads confuse eval
+^(??{chr 0x100}).$     \x{100}\x{100}  yt      $&      \x{100}\x{100}  threads confuse eval
+^(??{q(\x{100})}).     \x{100}\x{100}  yt      $&      \x{100}\x{100}  threads confuse eval
+^(??{q(.+)})\x{100}    \x{100}\x{100}  yt      $&      \x{100}\x{100}  threads confuse eval
+^(??{q(.)})\x{100}     \x{100}\x{100}  yt      $&      \x{100}\x{100}  threads confuse eval
+^(??{chr 0x100})\xbb   \x{100}\x{bb}   yt      $&      \x{100}\x{bb}   threads confuse eval
+^(.)(??{"(.)(.)"})(.)$ abcd    yt      $1-$2   a-d     threads confuse eval
+^(.)(??{"(bz+|.)(.)"})(.)$     abcd    yt      $1-$2   a-d     threads confuse eval
+^(.)((??{"(.)(cz+)"})|.)       abcd    yt      $1-$2   a-b     threads confuse eval
+^a(?>(??{q(b)}))(??{q(c)})d    abcd    yt      -       -       threads confuse eval
+^x(??{""})+$   x       yt      $&      x       threads confuse eval
 ^(<(?:[^<>]+|(?3)|(?1))*>)()(!>!>!>)$  <<!>!>!>><>>!>!>!>      y       $1      <<!>!>!>><>>
 ^(<(?:[^<>]+|(?1))*>)$ <<><<<><>>>>    y       $1      <<><<<><>>>>
 ((?2)*)([fF]o+)        fooFoFoo        y       $1-$2   fooFo-Foo
@@ -1040,13 +1040,13 @@ X(?<=foo.)[YZ]  ..XfooXY..      y       pos     8
 (?<n>foo|bar|baz)(?<m>[ew]+)   snofooewa       y       $+{n}   foo
 (?<n>foo|bar|baz)(?<m>[ew]+)   snofooewa       y       $+{m}   ew
 (?<n>foo)|(?<n>bar)|(?<n>baz)  snofooewa       y       $+{n}   foo
-(?<n>foo)(??{ $+{n} }) snofooefoofoowaa        y       $+{n}   foo
+(?<n>foo)(??{ $+{n} }) snofooefoofoowaa        yt      $+{n}   foo     threads confuse eval
 (?P<n>foo|bar|baz)     snofooewa       y       $1      foo
 (?P<n>foo|bar|baz)     snofooewa       y       $+{n}   foo
 (?P<n>foo|bar|baz)(?P<m>[ew]+) snofooewa       y       $+{n}   foo
 (?P<n>foo|bar|baz)(?P<m>[ew]+) snofooewa       y       $+{m}   ew
 (?P<n>foo)|(?P<n>bar)|(?P<n>baz)       snofooewa       y       $+{n}   foo
-(?P<n>foo)(??{ $+{n} })        snofooefoofoowaa        y       $+{n}   foo
+(?P<n>foo)(??{ $+{n} })        snofooefoofoowaa        yt      $+{n}   foo     threads confuse eval
 (?P<=n>foo|bar|baz)    snofooewa       c       -       Sequence (?P<=...) not recognized
 (?P<!n>foo|bar|baz)    snofooewa       c       -       Sequence (?P<!...) not recognized
 (?PX<n>foo|bar|baz)    snofooewa       c       -       Sequence (?PX<...) not recognized
@@ -1055,7 +1055,7 @@ X(?<=foo.)[YZ]    ..XfooXY..      y       pos     8
 /(?'n'foo|bar|baz)(?'m'[ew]+)/ snofooewa       y       $+{n}   foo
 /(?'n'foo|bar|baz)(?'m'[ew]+)/ snofooewa       y       $+{m}   ew
 /(?'n'foo)|(?'n'bar)|(?<n>baz)/        snobazewa       y       $+{n}   baz
-/(?'n'foo)(??{ $+{n} })/       snofooefoofoowaa        y       $+{n}   foo
+/(?'n'foo)(??{ $+{n} })/       snofooefoofoowaa        yt      $+{n}   foo     threads confuse eval
 /(?'n'foo)\k<n>/       ..foofoo..      y       $1      foo
 /(?'n'foo)\k<n>/       ..foofoo..      y       $+{n}   foo
 /(?<n>foo)\k'n'/       ..foofoo..      y       $1      foo
@@ -1295,7 +1295,7 @@ X(\w+)(?=\s)|X(\w+)       Xab     y       [$1-$2] [-ab]
 #Bug #41492
 (?(DEFINE)(?<A>(?&B)+)(?<B>a))(?&A)    a       y       $&      a
 (?(DEFINE)(?<A>(?&B)+)(?<B>a))(?&A)    aa      y       $&      aa
-\x{100}?(??{""})xxx    xxx     y       $&      xxx
+\x{100}?(??{""})xxx    xxx     yt      $&      xxx     threads confuse eval
 
 foo(\R)bar     foo\r\nbar      y       $1      \r\n
 foo(\R)bar     foo\nbar        y       $1      \n
index c53dd82..177820c 100644 (file)
@@ -66,13 +66,18 @@ my $email = qr {
     (?&address)
 }x;
 
-my $count = 0;
 
-$| = 1;
-while (<DATA>) {
-    chomp;
-    next if /^#/;
-    print /^$email$/ ? "ok " : "not ok ", ++ $count, "\n";
+run_tests() unless caller;
+
+sub run_tests {
+    my $count = 0;
+
+    $| = 1;
+    while (<DATA>) {
+       chomp;
+       next if /^#/;
+       print /^$email$/ ? "ok " : "not ok ", ++ $count, "\n";
+    }
 }
 
 #
diff --git a/t/op/reg_email_thr.t b/t/op/reg_email_thr.t
new file mode 100644 (file)
index 0000000..8eafc05
--- /dev/null
@@ -0,0 +1,7 @@
+#!./perl
+
+chdir 't' if -d 't';
+@INC = ('../lib', '.');
+
+require 'thread_it.pl';
+thread_it(qw(op reg_email.t));
index 8a13dd2..793a474 100755 (executable)
@@ -15,6 +15,7 @@
 #      c       expect an error
 #      B       test exposes a known bug in Perl, should be skipped
 #      b       test exposes a known bug in Perl, should be skipped if noamp
+#      t       test exposes a bug with threading, TODO if qr_embed_thr
 #
 # Columns 4 and 5 are used only if column 3 contains C<y> or C<c>.
 #
@@ -49,12 +50,25 @@ BEGIN {
 
     chdir 't' if -d 't';
     @INC = '../lib';
+
+    if ($qr_embed_thr) {
+       require Config;
+       if (!$Config::Config{useithreads}) {
+           print "1..0 # Skip: no ithreads\n";
+               exit 0;
+       }
+       if ($ENV{PERL_CORE_MINITEST}) {
+           print "1..0 # Skip: no dynamic loading on miniperl, no threads\n";
+               exit 0;
+       }
+       require threads;
+    }
 }
 
 use strict;
 use warnings FATAL=>"all";
 use vars qw($iters $numtests $bang $ffff $nulnul $OP);
-use vars qw($qr $skip_amp $qr_embed); # set by our callers
+use vars qw($qr $skip_amp $qr_embed $qr_embed_thr); # set by our callers
 
 
 if (!defined $file) {
@@ -73,6 +87,7 @@ $OP = $qr ? 'qr' : 'm';
 
 $| = 1;
 printf "1..%d\n# $iters iterations\n", scalar @tests;
+
 my $test;
 TEST:
 foreach (@tests) {
@@ -93,6 +108,7 @@ foreach (@tests) {
     $subject = eval qq("$subject"); die $@ if $@;
     $expect  = eval qq("$expect"); die $@ if $@;
     $expect = $repl = '-' if $skip_amp and $input =~ /\$[&\`\']/;
+    my $todo = $qr_embed_thr && ($result =~ s/t//);
     my $skip = ($skip_amp ? ($result =~ s/B//i) : ($result =~ s/B//));
     $reason = 'skipping $&' if $reason eq  '' && $skip_amp;
     $result =~ s/B//i unless $skip;
@@ -118,6 +134,16 @@ EOFCODE
                 $study;
                 \$match = (\$subject =~ /(?:)\$RE(?:)/) while \$c--;
                 \$got = "$repl";
+EOFCODE
+        }
+        elsif ($qr_embed_thr) {
+            $code= <<EOFCODE;
+               # Can't run the match in a subthread, but can do this and
+               # clone the pattern the other way.
+                my \$RE = threads->new(sub {qr$pat})->join();
+                $study;
+                \$match = (\$subject =~ /(?:)\$RE(?:)/) while \$c--;
+                \$got = "$repl";
 EOFCODE
         }
         else {
@@ -146,10 +172,14 @@ EOFCODE
            print "ok $test # skipped", length($reason) ? " $reason" : '', "\n";
            next TEST;
        }
+       elsif ( $todo ) {
+           print "not ok $test # todo", length($reason) ? " - $reason" : '', "\n";
+           next TEST;
+       }
        elsif ($@) {
            print "not ok $test $input => error `$err'\n$code\n$@\n"; next TEST;
        }
-       elsif ($result eq 'n') {
+       elsif ($result =~ /^n/) {
            if ($match) { print "not ok $test ($study) $input => false positive\n"; next TEST }
        }
        else {
diff --git a/t/op/regexp_qr_embed_thr.t b/t/op/regexp_qr_embed_thr.t
new file mode 100644 (file)
index 0000000..4f91bd4
--- /dev/null
@@ -0,0 +1,11 @@
+#!./perl
+
+$qr = 1;
+$qr_embed_thr = 1;
+for $file ('./op/regexp.t', './t/op/regexp.t', ':op:regexp.t') {
+    if (-r $file) {
+       do $file or die $@;
+       exit;
+    }
+}
+die "Cannot find ./op/regexp.t or ./t/op/regexp.t\n";
index 40f8766..81c87be 100755 (executable)
@@ -25,6 +25,12 @@ require './test.pl';
 
 plan(334);
 
+run_tests() unless caller;
+
+my $krunch = "a";
+
+sub run_tests {
+
 $FATAL_MSG = qr/^substr outside of string/;
 
 is(substr($a,0,3), 'abc');   # P=Q R S
@@ -643,11 +649,10 @@ is($x, "\x{100}\x{200}\xFFb");
 # [perl #24200] string corruption with lvalue sub
 
 {
-    my $foo = "a";
-    sub bar: lvalue { substr $foo, 0 }
+    sub bar: lvalue { substr $krunch, 0 }
     bar = "XXX";
     is(bar, 'XXX');
-    $foo = '123456789';
+    $krunch = '123456789';
     is(bar, '123456789');
 }
 
@@ -675,3 +680,5 @@ is($x, "\x{100}\x{200}\xFFb");
     is(substr($a,1,2), 'bc');
     is(substr($a,1,1), 'b');
 }
+
+}
diff --git a/t/op/substr_thr.t b/t/op/substr_thr.t
new file mode 100644 (file)
index 0000000..babb48d
--- /dev/null
@@ -0,0 +1,7 @@
+#!./perl
+
+chdir 't' if -d 't';
+@INC = ('../lib', '.');
+
+require 'thread_it.pl';
+thread_it(qw(op substr.t));
diff --git a/t/thread_it.pl b/t/thread_it.pl
new file mode 100644 (file)
index 0000000..feec254
--- /dev/null
@@ -0,0 +1,39 @@
+#!perl
+use strict;
+use warnings;
+
+use Config;
+if (!$Config{useithreads}) {
+    print "1..0 # Skip: no ithreads\n";
+    exit 0;
+}
+if ($ENV{PERL_CORE_MINITEST}) {
+    print "1..0 # Skip: no dynamic loading on miniperl, no threads\n";
+    exit 0;
+}
+
+require threads;
+
+sub thread_it {
+    # Generate things like './op/regexp.t', './t/op/regexp.t', ':op:regexp.t'
+    my @paths
+       = (join ('/', '.', @_), join ('/', '.', 't', @_), join (':', @_));
+                
+    for my $file (@paths) {
+       if (-r $file) {
+           print "# found tests in $file\n";
+           $::running_as_thread = "running tests in a new thread";
+           do $file or die $@;
+           print "# running tests in a new thread\n";
+           my $curr = threads->create(sub {
+               run_tests();
+               return defined &curr_test ? curr_test() : ()
+           })->join();
+           curr_test($curr) if defined $curr;
+           exit;
+       }
+    }
+    die "Cannot find " . join (" or ", @paths) . "\n";
+}
+
+1;