Change 33920 by [EMAIL PROTECTED] on 2008/05/24 16:04:48
Integrate:
[ 32931]
Variants of several regression tests that run the actul tests inside
a new thread, to test ithread's cloning, particularly of regexps.
[ 33919]
make TODO output TAP-compliant in regexp.t
Affected files ...
... //depot/maint-5.10/perl/MANIFEST#24 integrate
... //depot/maint-5.10/perl/t/op/index.t#2 integrate
... //depot/maint-5.10/perl/t/op/index_thr.t#1 branch
... //depot/maint-5.10/perl/t/op/pat.t#8 integrate
... //depot/maint-5.10/perl/t/op/pat_thr.t#1 branch
... //depot/maint-5.10/perl/t/op/re_tests#3 integrate
... //depot/maint-5.10/perl/t/op/reg_email.t#2 integrate
... //depot/maint-5.10/perl/t/op/reg_email_thr.t#1 branch
... //depot/maint-5.10/perl/t/op/regexp.t#3 integrate
... //depot/maint-5.10/perl/t/op/regexp_qr_embed_thr.t#1 branch
... //depot/maint-5.10/perl/t/op/substr.t#2 integrate
... //depot/maint-5.10/perl/t/op/substr_thr.t#1 branch
... //depot/maint-5.10/perl/t/thread_it.pl#1 branch
Differences ...
==== //depot/maint-5.10/perl/MANIFEST#24 (text) ====
Index: perl/MANIFEST
--- perl/MANIFEST#23~33882~ 2008-05-20 07:05:51.000000000 -0700
+++ perl/MANIFEST 2008-05-24 09:04:48.000000000 -0700
@@ -3788,6 +3788,7 @@
t/op/incfilter.t See if the source filters in [EMAIL PROTECTED]
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
@@ -3817,6 +3818,7 @@
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
@@ -3833,9 +3835,11 @@
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
@@ -3869,6 +3873,7 @@
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
@@ -3958,6 +3963,7 @@
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
==== //depot/maint-5.10/perl/t/op/index.t#2 (xtext) ====
Index: perl/t/op/index.t
--- perl/t/op/index.t#1~32694~ 2007-12-22 01:23:09.000000000 -0800
+++ perl/t/op/index.t 2008-05-24 09:04:48.000000000 -0700
@@ -9,6 +9,10 @@
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 @@
local ${^UTF8CACHE} = -1;
is(index($t, 'xyz'), 4, "0xfffffffd and utf8cache");
}
+
+}
==== //depot/maint-5.10/perl/t/op/index_thr.t#1 (text) ====
Index: perl/t/op/index_thr.t
--- /dev/null 2008-05-07 15:08:24.549929899 -0700
+++ perl/t/op/index_thr.t 2008-05-24 09:04:48.000000000 -0700
@@ -0,0 +1,7 @@
+#!./perl
+
+chdir 't' if -d 't';
[EMAIL PROTECTED] = ('../lib', '.');
+
+require 'thread_it.pl';
+thread_it(qw(op index.t));
==== //depot/maint-5.10/perl/t/op/pat.t#8 (xtext) ====
Index: perl/t/op/pat.t
--- perl/t/op/pat.t#7~33823~ 2008-05-12 03:24:27.000000000 -0700
+++ perl/t/op/pat.t 2008-05-24 09:04:48.000000000 -0700
@@ -16,6 +16,10 @@
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 "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 @@
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 "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 @@
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 "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;
@@ -4533,7 +4554,12 @@
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;
@@ -4648,8 +4674,13 @@
# 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 = 4024;
print "1..$::TestCount\n";
}
+
+"Truth";
==== //depot/maint-5.10/perl/t/op/pat_thr.t#1 (text) ====
Index: perl/t/op/pat_thr.t
--- /dev/null 2008-05-07 15:08:24.549929899 -0700
+++ perl/t/op/pat_thr.t 2008-05-24 09:04:48.000000000 -0700
@@ -0,0 +1,7 @@
+#!./perl
+
+chdir 't' if -d 't';
[EMAIL PROTECTED] = ('../lib', '.');
+
+require 'thread_it.pl';
+thread_it(qw(op pat.t));
==== //depot/maint-5.10/perl/t/op/re_tests#3 (text) ====
Index: perl/t/op/re_tests
--- perl/t/op/re_tests#2~33133~ 2008-01-30 10:46:51.000000000 -0800
+++ perl/t/op/re_tests 2008-05-24 09:04:48.000000000 -0700
@@ -503,14 +503,14 @@
'(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 @@
^(\(+)?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 @@
([\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$'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 @@
(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 @@
(.*?)(?<=[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.|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.)[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 @@
(?<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 @@
/(?'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 @@
#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
==== //depot/maint-5.10/perl/t/op/reg_email.t#2 (text) ====
Index: perl/t/op/reg_email.t
--- perl/t/op/reg_email.t#1~32694~ 2007-12-22 01:23:09.000000000 -0800
+++ perl/t/op/reg_email.t 2008-05-24 09:04:48.000000000 -0700
@@ -66,13 +66,18 @@
(?&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";
+ }
}
#
==== //depot/maint-5.10/perl/t/op/reg_email_thr.t#1 (text) ====
Index: perl/t/op/reg_email_thr.t
--- /dev/null 2008-05-07 15:08:24.549929899 -0700
+++ perl/t/op/reg_email_thr.t 2008-05-24 09:04:48.000000000 -0700
@@ -0,0 +1,7 @@
+#!./perl
+
+chdir 't' if -d 't';
[EMAIL PROTECTED] = ('../lib', '.');
+
+require 'thread_it.pl';
+thread_it(qw(op reg_email.t));
==== //depot/maint-5.10/perl/t/op/regexp.t#3 (xtext) ====
Index: perl/t/op/regexp.t
--- perl/t/op/regexp.t#2~33133~ 2008-01-30 10:46:51.000000000 -0800
+++ perl/t/op/regexp.t 2008-05-24 09:04:48.000000000 -0700
@@ -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 @@
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 @@
$| = 1;
printf "1..%d\n# $iters iterations\n", scalar @tests;
+
my $test;
TEST:
foreach (@tests) {
@@ -93,6 +108,7 @@
$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;
@@ -120,6 +136,16 @@
\$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 {
$code= <<EOFCODE;
$study;
@@ -146,10 +172,14 @@
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'[EMAIL PROTECTED]"; next
TEST;
}
- elsif ($result eq 'n') {
+ elsif ($result =~ /^n/) {
if ($match) { print "not ok $test ($study) $input => false
positive\n"; next TEST }
}
else {
==== //depot/maint-5.10/perl/t/op/regexp_qr_embed_thr.t#1 (text) ====
Index: perl/t/op/regexp_qr_embed_thr.t
--- /dev/null 2008-05-07 15:08:24.549929899 -0700
+++ perl/t/op/regexp_qr_embed_thr.t 2008-05-24 09:04:48.000000000 -0700
@@ -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";
==== //depot/maint-5.10/perl/t/op/substr.t#2 (xtext) ====
Index: perl/t/op/substr.t
--- perl/t/op/substr.t#1~32694~ 2007-12-22 01:23:09.000000000 -0800
+++ perl/t/op/substr.t 2008-05-24 09:04:48.000000000 -0700
@@ -25,6 +25,12 @@
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 @@
# [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(substr($a,1,2), 'bc');
is(substr($a,1,1), 'b');
}
+
+}
==== //depot/maint-5.10/perl/t/op/substr_thr.t#1 (text) ====
Index: perl/t/op/substr_thr.t
--- /dev/null 2008-05-07 15:08:24.549929899 -0700
+++ perl/t/op/substr_thr.t 2008-05-24 09:04:48.000000000 -0700
@@ -0,0 +1,7 @@
+#!./perl
+
+chdir 't' if -d 't';
[EMAIL PROTECTED] = ('../lib', '.');
+
+require 'thread_it.pl';
+thread_it(qw(op substr.t));
==== //depot/maint-5.10/perl/t/thread_it.pl#1 (text) ====
Index: perl/t/thread_it.pl
--- /dev/null 2008-05-07 15:08:24.549929899 -0700
+++ perl/t/thread_it.pl 2008-05-24 09:04:48.000000000 -0700
@@ -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;
End of Patch.
