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;
# Force scalar context on the patern match
sub ok ($;$) {
my($ok, $name) = @_;
+ my $todo = $TODO ? " # TODO $TODO" : '';
printf "%sok %d - %s\n", ($ok ? "" : "not "), $test,
- ($name||$Message)."\tLine ".((caller)[2]);
+ ($name||$Message)."$todo\tLine ".((caller)[2]);
printf "# Failed test at line %d\n", (caller)[2] unless $ok;
ok($a !~ /^\C{4}y/, q{don't match \C{4}y});
}
-$_ = 'aaaaaaaaaa';
-utf8::upgrade($_); chop $_; $\="\n";
-ok(/[^\s]+/, "m/[^\s]/ utf8");
-ok(/[^\d]+/, "m/[^\d]/ utf8");
-ok(($a = $_, $_ =~ s/[^\s]+/./g), "s/[^\s]/ utf8");
-ok(($a = $_, $a =~ s/[^\d]+/./g), "s/[^\s]/ utf8");
+{
+ local $\;
+ $_ = 'aaaaaaaaaa';
+ utf8::upgrade($_); chop $_; $\="\n";
+ ok(/[^\s]+/, "m/[^\s]/ utf8");
+ ok(/[^\d]+/, "m/[^\d]/ utf8");
+ ok(($a = $_, $_ =~ s/[^\s]+/./g), "s/[^\s]/ utf8");
+ ok(($a = $_, $a =~ s/[^\d]+/./g), "s/[^\s]/ utf8");
+}
ok("\x{100}" =~ /\x{100}/, "[perl #15397]");
ok("\x{100}" =~ /(\x{100})/, "[perl #15397]");
foreach (1,2,3,4) {
$p++ if /(??{ $p })/
}
- ok ($p == 5, "[perl #20683] (??{ }) returns stale values");
+ iseq ($p, 5, "[perl #20683] (??{ }) returns stale values");
{ package P; $a=1; sub TIESCALAR { bless[] } sub FETCH { $a++ } }
tie $p, P;
foreach (1,2,3,4) {
/(??{ $p })/
}
- ok ( $p == 5, "(??{ }) returns stale values");
+ iseq ( $p, 5, "(??{ }) returns stale values");
}
{
ok($utf8 =~ /(abc|\xe9)/i, "utf8/latin trie");
ok($utf8 =~ /(abc|$latin1)/i, "utf8/latin trie runtime");
- ok("\xe9" =~ /$utf8/i, "# TODO latin/utf8");
+ ok("\xe9" =~ /$utf8/i, "# latin/utf8");
ok("\xe9" =~ /(abc|$utf8)/i, "# latin/utf8 trie");
- ok($latin1 =~ /$utf8/i, "# TODO latin/utf8 runtime");
+ ok($latin1 =~ /$utf8/i, "# latin/utf8 runtime");
ok($latin1 =~ /(abc|$utf8)/i, "# latin/utf8 trie runtime");
}
}
{
+ local $TODO = "See changes 26925-26928, which reverted change 26410";
package lv;
$var = "abc";
sub variable : lvalue { $var }
my $o = bless [], "lv";
my $f = "";
eval { for (1..2) { $f .= $1 if $o->variable =~ /(.)/g } };
- ok($f eq "ab", "pos retained between calls # TODO") or print "# $@\n";
+ ok($f eq "ab", "pos retained between calls") or print "# $@\n";
}
{
+ local $TODO = "See changes 26925-26928, which reverted change 26410";
$var = "abc";
sub variable : lvalue { $var }
my $f = "";
eval { for (1..2) { $f .= $1 if variable() =~ /(.)/g } };
- ok($f eq "ab", "pos retained between calls # TODO") or print "# $@\n";
+ ok($f eq "ab", "pos retained between calls") or print "# $@\n";
}
# [perl #37836] Simple Regex causes SEGV when run on specific data
sub iseq($$;$) {
my ( $got, $expect, $name)=@_;
+ my $todo = $TODO ? " # TODO $TODO" : '';
$_=defined($_) ? "'$_'" : "undef"
for $got, $expect;
my $ok= $got eq $expect;
- printf "%sok %d - %s\n", ($ok ? "" : "not "), $test,
+ printf "%sok %d - %s$todo\n", ($ok ? "" : "not "), $test,
($name||$Message)."\tLine ".((caller)[2]);
printf "# Failed test at line %d\n".
iseq($^R,'Nothing');
}
{
- local $Message="RT#22395";
+ local $Message="RT 22395";
+ local $TODO = "Should be L+1 not L*(L+3)/2 (L=$l)";
our $count;
for my $l (10,100,1000) {
$count=0;
('a' x $l) =~ /(.*)(?{$count++})[bc]/;
- iseq( $count, $l + 1, "# TODO Should be L+1 not L*(L+3)/2 (L=$l)");
+ iseq( $count, $l + 1);
}
}
{
}
iseq(length($str),"0","Trie scope error, string should be empty");
}
+{
+# [perl #45605] Regexp failure with utf8-flagged and byte-flagged string
+
+ my $utf_8 = "\xd6schel";
+ utf8::upgrade($utf_8);
+ $utf_8 =~ m{(\xd6|Ö)schel};
+ iseq($1,"\xd6","#45605");
+}
+
+{
+ # Regardless of utf8ness any character matches itself when
+ # doing a case insensitive match. See also [perl #36207]
+ for my $o (0..255) {
+ my @ch=(chr($o),chr($o));
+ utf8::upgrade($ch[1]);
+ for my $u_str (0,1) {
+ for my $u_pat (0,1) {
+ ok( $ch[$u_str]=~/\Q$ch[$u_pat]\E/i,
+ "\$c=~/\$c/i : chr($o) : u_str=$u_str u_pat=$u_pat");
+ ok( $ch[$u_str]=~/\Q$ch[$u_pat]\E|xyz/i,
+ "# \$c=~/\$c|xyz/i : chr($o) : u_str=$u_str u_pat=$u_pat");
+ }
+ }
+ }
+}
+{
+ my $a = 3; "" =~ /(??{ $a })/;
+ my $b = $a;
+ iseq($b, $a, "copy of scalar used for postponed subexpression");
+}
+{
+ local $Message = "\$REGMARK in replacement -- Bug #49190";
+ my $_ = "A";
+ s/(*:B)A/$REGMARK/;
+ iseq $_, "B";
+ $_ = "CCCCBAA";
+ 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;
+ $nested_tags = qr{
+ <
+ (\w+)
+ (?{
+ push @ctl_n,$^N;
+ push @plus,$+;
+ })
+ >
+ (??{$nested_tags})*
+ </\s* \w+ \s*>
+ }x;
+
+ my $match= '<bla><blubb></blubb></bla>' =~ m/^$nested_tags$/;
+ ok($match,'nested construct matches');
+ iseq("@ctl_n","bla blubb",'$^N inside of (?{}) works as expected');
+ iseq("@plus","bla blubb",'$+ inside of (?{}) works as expected');
+}
+
+
+
# Test counter is at bottom of file. Put new tests above here.
#-------------------------------------------------------------------
iseq($_,"!Bang!1!Bang!2!Bang!3!Bang!");
}
+# [perl #45337] utf8 + "[a]a{2}" + /$.../ = panic: sv_len_utf8 cache
+
+{
+ local ${^UTF8CACHE} = -1;
+ my $s="[a]a{2}";
+ utf8::upgrade $s;
+ ok("aaa" =~ /$s/, "#45337");
+}
+
# 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 = 1963;
+ $::TestCount = 4019;
print "1..$::TestCount\n";
}
+
+"Truth";
https://perl5.git.perl.org / perl5.git / blobdiff