a new thread, to test ithread's cloning, particularly of regexps.
p4raw-id: //depot/perl@32931
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
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
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
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
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
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'));
local ${^UTF8CACHE} = -1;
is(index($t, 'xyz'), 4, "0xfffffffd and utf8cache");
}
+
+}
--- /dev/null
+#!./perl
+
+chdir 't' if -d 't';
+@INC = ('../lib', '.');
+
+require 'thread_it.pl';
+thread_it(qw(op index.t));
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";}
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;
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);
}
{
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";
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;
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;
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;
# 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";
--- /dev/null
+#!./perl
+
+chdir 't' if -d 't';
+@INC = ('../lib', '.');
+
+require 'thread_it.pl';
+thread_it(qw(op pat.t));
'(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
^(\(+)?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 - -
([\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 :[
'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-
(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
(.*?)(?<=[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]
(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]
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
(?<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
/(?'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
#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
(?&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";
+ }
}
#
--- /dev/null
+#!./perl
+
+chdir 't' if -d 't';
+@INC = ('../lib', '.');
+
+require 'thread_it.pl';
+thread_it(qw(op reg_email.t));
# 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>.
#
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) {
$| = 1;
printf "1..%d\n# $iters iterations\n", scalar @tests;
+
my $test;
TEST:
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;
\$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;
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 {
--- /dev/null
+#!./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";
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
# [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');
}
is(substr($a,1,2), 'bc');
is(substr($a,1,1), 'b');
}
+
+}
--- /dev/null
+#!./perl
+
+chdir 't' if -d 't';
+@INC = ('../lib', '.');
+
+require 'thread_it.pl';
+thread_it(qw(op substr.t));
--- /dev/null
+#!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;
projects / p5sagit/p5-mst-13.2.git / commitdiff