From: Nicholas Clark Date: Wed, 9 Jan 2008 22:42:04 +0000 (+0000) Subject: Variants of several regression tests that run the actul tests inside X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e3faa678eb30e1e08116ca1bd086624974e5e5aa;p=p5sagit%2Fp5-mst-13.2.git Variants of several regression tests that run the actul tests inside a new thread, to test ithread's cloning, particularly of regexps. p4raw-id: //depot/perl@32931 --- diff --git a/MANIFEST b/MANIFEST index d09923c..91a450f 100644 --- 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 diff --git a/t/op/index.t b/t/op/index.t index b384bef..38da96c 100755 --- a/t/op/index.t +++ b/t/op/index.t @@ -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 index 0000000..3a97741 --- /dev/null +++ b/t/op/index_thr.t @@ -0,0 +1,7 @@ +#!./perl + +chdir 't' if -d 't'; +@INC = ('../lib', '.'); + +require 'thread_it.pl'; +thread_it(qw(op index.t)); diff --git a/t/op/pat.t b/t/op/pat.t index 0e16cd9..2ccc07c 100755 --- a/t/op/pat.t +++ b/t/op/pat.t @@ -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 index 0000000..3228b33 --- /dev/null +++ b/t/op/pat_thr.t @@ -0,0 +1,7 @@ +#!./perl + +chdir 't' if -d 't'; +@INC = ('../lib', '.'); + +require 'thread_it.pl'; +thread_it(qw(op pat.t)); diff --git a/t/op/re_tests b/t/op/re_tests index c2397e6..6f4db07 100644 --- a/t/op/re_tests +++ b/t/op/re_tests @@ -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 (?foo|bar|baz)(?[ew]+) snofooewa y $+{n} foo (?foo|bar|baz)(?[ew]+) snofooewa y $+{m} ew (?foo)|(?bar)|(?baz) snofooewa y $+{n} foo -(?foo)(??{ $+{n} }) snofooefoofoowaa y $+{n} foo +(?foo)(??{ $+{n} }) snofooefoofoowaa yt $+{n} foo threads confuse eval (?Pfoo|bar|baz) snofooewa y $1 foo (?Pfoo|bar|baz) snofooewa y $+{n} foo (?Pfoo|bar|baz)(?P[ew]+) snofooewa y $+{n} foo (?Pfoo|bar|baz)(?P[ew]+) snofooewa y $+{m} ew (?Pfoo)|(?Pbar)|(?Pbaz) snofooewa y $+{n} foo -(?Pfoo)(??{ $+{n} }) snofooefoofoowaa y $+{n} foo +(?Pfoo)(??{ $+{n} }) snofooefoofoowaa yt $+{n} foo threads confuse eval (?P<=n>foo|bar|baz) snofooewa c - Sequence (?P<=...) not recognized (?Pfoo|bar|baz) snofooewa c - Sequence (?Pfoo|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)|(?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/ ..foofoo.. y $1 foo /(?'n'foo)\k/ ..foofoo.. y $+{n} foo /(?foo)\k'n'/ ..foofoo.. y $1 foo @@ -1295,7 +1295,7 @@ X(\w+)(?=\s)|X(\w+) Xab y [$1-$2] [-ab] #Bug #41492 (?(DEFINE)(?(?&B)+)(?a))(?&A) a y $& a (?(DEFINE)(?(?&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 diff --git a/t/op/reg_email.t b/t/op/reg_email.t index c53dd82..177820c 100644 --- a/t/op/reg_email.t +++ b/t/op/reg_email.t @@ -66,13 +66,18 @@ my $email = qr { (?&address) }x; -my $count = 0; -$| = 1; -while () { - chomp; - next if /^#/; - print /^$email$/ ? "ok " : "not ok ", ++ $count, "\n"; +run_tests() unless caller; + +sub run_tests { + my $count = 0; + + $| = 1; + while () { + 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 index 0000000..8eafc05 --- /dev/null +++ b/t/op/reg_email_thr.t @@ -0,0 +1,7 @@ +#!./perl + +chdir 't' if -d 't'; +@INC = ('../lib', '.'); + +require 'thread_it.pl'; +thread_it(qw(op reg_email.t)); diff --git a/t/op/regexp.t b/t/op/regexp.t index 8a13dd2..793a474 100755 --- a/t/op/regexp.t +++ b/t/op/regexp.t @@ -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 or 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; @@ -120,6 +136,16 @@ EOFCODE \$got = "$repl"; EOFCODE } + elsif ($qr_embed_thr) { + $code= <new(sub {qr$pat})->join(); + $study; + \$match = (\$subject =~ /(?:)\$RE(?:)/) while \$c--; + \$got = "$repl"; +EOFCODE + } else { $code= < 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 index 0000000..4f91bd4 --- /dev/null +++ b/t/op/regexp_qr_embed_thr.t @@ -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"; diff --git a/t/op/substr.t b/t/op/substr.t index 40f8766..81c87be 100755 --- a/t/op/substr.t +++ b/t/op/substr.t @@ -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 index 0000000..babb48d --- /dev/null +++ b/t/op/substr_thr.t @@ -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 index 0000000..feec254 --- /dev/null +++ b/t/thread_it.pl @@ -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;