chdir 't' if -d 't';
@INC = '../lib';
}
+our $Message = "Noname test";
eval 'use Config'; # Defaults assumed if this fails
pos($foo)=1;
$foo=~/.\G(..)/g;
-print "not " unless($1 eq 'ab');
-print "ok $test\n";
-$test++;
+iseq($1,'ab');
pos($foo) += 1;
$foo=~/.\G(..)/g;
@b = grep(/\w/,@a);
@c = grep(/[\w]/,@a);
-print "not " if "@b" ne "@c";
-print "ok $test\n";
-$test++;
+iseq("@b","@c");
# see if backtracking optimization works correctly
"\n\n" =~ /\n $ \n/x or print "not ";
sub ok ($;$) {
my($ok, $name) = @_;
- printf "%sok %d - %s\n", ($ok ? "" : "not "), $test, $name||'unnamed';
+ printf "%sok %d - %s\n", ($ok ? "" : "not "), $test,
+ ($name||$Message)."\tLine ".((caller)[2]);
printf "# Failed test at line %d\n", (caller)[2] unless $ok;
#$_ = "x"; /x(?{func "in regexp"})/;
#$_ = "x"; /x(?{func "in multiline regexp"})/m;
-# bug #19049
+# bug RT#19049
$_="abcdef\n";
@x = m/./g;
-ok("abcde" eq "$`", '# TODO #19049 - global match not setting $`');
+ok("abcde" eq "$`", 'RT#19049 - global match not setting $`');
ok("123\x{100}" =~ /^.*1.*23\x{100}$/, 'uft8 + multiple floating substr');
$s=~s/(?'digits'\d+)\k'digits'/$+{digits}/;
ok($s eq '123456','Named capture (single quotes) s///');
}
+
+{
+ my @ary = (
+ pack('U', 0x00F1), # n-tilde
+ '_'.pack('U', 0x00F1), # _ + n-tilde
+ 'c'.pack('U', 0x0327), # c + cedilla
+ pack('U*', 0x00F1, 0x0327), # n-tilde + cedilla
+ 'a'.pack('U', 0x00B2), # a + superscript two
+ pack('U', 0x0391), # ALPHA
+ pack('U', 0x0391).'2', # ALPHA + 2
+ pack('U', 0x0391).'_', # ALPHA + _
+ );
+ for my $uni (@ary) {
+ my ($r1, $c1, $r2, $c2) = eval qq{
+ use utf8;
+ scalar("..foo foo.." =~ /(?'${uni}'foo) \\k'${uni}'/),
+ \$+{${uni}},
+ scalar("..bar bar.." =~ /(?<${uni}>bar) \\k<${uni}>/),
+ \$+{${uni}};
+ };
+ ok($r1, "Named capture UTF (?'')");
+ ok(defined $c1 && $c1 eq 'foo', "Named capture UTF \%+");
+ ok($r2, "Named capture UTF (?<>)");
+ ok(defined $c2 && $c2 eq 'bar', "Named capture UTF \%+");
+ }
+}
+
sub iseq($$;$) {
my ( $got, $expect, $name)=@_;
my $ok= $got eq $expect;
- printf "%sok %d - %s\n", ($ok ? "" : "not "), $test, $name||'unnamed';
+ printf "%sok %d - %s\n", ($ok ? "" : "not "), $test,
+ ($name||$Message)."\tLine ".((caller)[2]);
printf "# Failed test at line %d\n".
"# expected: %s\n".
';
ok(!$@,'lvalue $+{...} should not throw an exception');
}
-
+{
+ my $s='foo bar baz';
+ my @res;
+ if ('1234'=~/(?<A>1)(?<B>2)(?<A>3)(?<B>4)/) {
+ foreach my $name (sort keys(%-)) {
+ my $ary = $-{$name};
+ foreach my $idx (0..$#$ary) {
+ push @res,"$name:$idx:$ary->[$idx]";
+ }
+ }
+ }
+ my @expect=qw(A:0:1 A:1:3 B:0:2 B:1:4);
+ iseq("@res","@expect","Check %-");
+ eval'
+ print for $-{this_key_doesnt_exist};
+ ';
+ ok(!$@,'lvalue $-{...} should not throw an exception');
+}
# stress test CURLYX/WHILEM.
#
# This test includes varying levels of nesting, and according to
iseq($count,1,"should have matched once only [RT#36046]");
}
-{ # Test the (*NOMATCH) pattern
+{ # Test the (*PRUNE) pattern
+ our $count = 0;
+ 'aaab'=~/a+b?(?{$count++})(*FAIL)/;
+ iseq($count,9,"expect 9 for no (*PRUNE)");
+ $count = 0;
+ 'aaab'=~/a+b?(*PRUNE)(?{$count++})(*FAIL)/;
+ iseq($count,3,"expect 3 with (*PRUNE)");
+ local $_='aaab';
+ $count=0;
+ 1 while /.(*PRUNE)(?{$count++})(*FAIL)/g;
+ iseq($count,4,"/.(*PRUNE)/");
+ $count = 0;
+ 'aaab'=~/a+b?(??{'(*PRUNE)'})(?{$count++})(*FAIL)/;
+ iseq($count,3,"expect 3 with (*PRUNE)");
+ local $_='aaab';
+ $count=0;
+ 1 while /.(??{'(*PRUNE)'})(?{$count++})(*FAIL)/g;
+ iseq($count,4,"/.(*PRUNE)/");
+}
+{ # Test the \v form of the (*PRUNE) pattern
our $count = 0;
'aaab'=~/a+b?(?{$count++})(*FAIL)/;
- iseq($count,9,"expect 9 for no (*NOMATCH)");
+ iseq($count,9,"expect 9 for no \\v");
$count = 0;
- 'aaab'=~/a+b?(*NOMATCH)(?{$count++})(*FAIL)/;
- iseq($count,3,"expect 3 with (*NOMATCH)");
+ 'aaab'=~/a+b?\v(?{$count++})(*FAIL)/;
+ iseq($count,3,"expect 3 with \\v");
local $_='aaab';
$count=0;
- 1 while /.(*NOMATCH)(?{$count++})(*FAIL)/g;
- iseq($count,4,"/.(*NOMATCH)/");
+ 1 while /.\v(?{$count++})(*FAIL)/g;
+ iseq($count,4,"/.\\v/");
$count = 0;
- 'aaab'=~/a+b?(??{'(*NOMATCH)'})(?{$count++})(*FAIL)/;
- iseq($count,3,"expect 3 with (*NOMATCH)");
+ 'aaab'=~/a+b?(??{'\v'})(?{$count++})(*FAIL)/;
+ iseq($count,3,"expect 3 with \\v");
local $_='aaab';
$count=0;
- 1 while /.(??{'(*NOMATCH)'})(?{$count++})(*FAIL)/g;
- iseq($count,4,"/.(*NOMATCH)/");
+ 1 while /.(??{'\v'})(?{$count++})(*FAIL)/g;
+ iseq($count,4,"/.\\v/");
+}
+{ # Test the (*SKIP) pattern
+ our $count = 0;
+ 'aaab'=~/a+b?(*SKIP)(?{$count++})(*FAIL)/;
+ iseq($count,1,"expect 1 with (*SKIP)");
+ local $_='aaab';
+ $count=0;
+ 1 while /.(*SKIP)(?{$count++})(*FAIL)/g;
+ iseq($count,4,"/.(*SKIP)/");
+ $_='aaabaaab';
+ $count=0;
+ our @res=();
+ 1 while /(a+b?)(*SKIP)(?{$count++; push @res,$1})(*FAIL)/g;
+ iseq($count,2,"Expect 2 with (*SKIP)" );
+ iseq("@res","aaab aaab","adjacent (*SKIP) works as expected" );
}
-{ # Test the (*CUT) pattern
+{ # Test the \V form of the (*SKIP) pattern
our $count = 0;
- 'aaab'=~/a+b?(*CUT)(?{$count++})(*FAIL)/;
- iseq($count,1,"expect 1 with (*CUT)");
+ 'aaab'=~/a+b?\V(?{$count++})(*FAIL)/;
+ iseq($count,1,"expect 1 with \\V");
local $_='aaab';
$count=0;
- 1 while /.(*CUT)(?{$count++})(*FAIL)/g;
- iseq($count,4,"/.(*CUT)/");
+ 1 while /.\V(?{$count++})(*FAIL)/g;
+ iseq($count,4,"/.\\V/");
$_='aaabaaab';
$count=0;
our @res=();
- 1 while /(a+b?)(*CUT)(?{$count++; push @res,$1})(*FAIL)/g;
- iseq($count,2,"Expect 2 with (*CUT)" );
- iseq("@res","aaab aaab","adjacent (*CUT) works as expected" );
+ 1 while /(a+b?)\V(?{$count++; push @res,$1})(*FAIL)/g;
+ iseq($count,2,"Expect 2 with \\V" );
+ iseq("@res","aaab aaab","adjacent \\V works as expected" );
}
-{ # Test the (*CUT) pattern
+{ # Test the (*SKIP) pattern
our $count = 0;
- 'aaab'=~/a+b?(*MARK)(*CUT)(?{$count++})(*FAIL)/;
- iseq($count,1,"expect 1 with (*CUT)");
+ 'aaab'=~/a+b?(*MARK:foo)(*SKIP)(?{$count++})(*FAIL)/;
+ iseq($count,1,"expect 1 with (*SKIP)");
local $_='aaab';
$count=0;
- 1 while /.(*MARK)(*CUT)(?{$count++})(*FAIL)/g;
- iseq($count,4,"/.(*CUT)/");
+ 1 while /.(*MARK:foo)(*SKIP)(?{$count++})(*FAIL)/g;
+ iseq($count,4,"/.(*SKIP)/");
$_='aaabaaab';
$count=0;
our @res=();
- 1 while /(a+b?)(*MARK)(*CUT)(?{$count++; push @res,$1})(*FAIL)/g;
- iseq($count,2,"Expect 2 with (*CUT)" );
- iseq("@res","aaab aaab","adjacent (*CUT) works as expected" );
+ 1 while /(a+b?)(*MARK:foo)(*SKIP)(?{$count++; push @res,$1})(*FAIL)/g;
+ iseq($count,2,"Expect 2 with (*SKIP)" );
+ iseq("@res","aaab aaab","adjacent (*SKIP) works as expected" );
}
-{ # Test the (*CUT) pattern
+{ # Test the (*SKIP) pattern
our $count = 0;
- 'aaab'=~/a*(*MARK:a)b?(*MARK:b)(*CUT:a)(?{$count++})(*FAIL)/;
- iseq($count,3,"expect 3 with *MARK:a)b?(*MARK:b)(*CUT:a)");
+ 'aaab'=~/a*(*MARK:a)b?(*MARK:b)(*SKIP:a)(?{$count++})(*FAIL)/;
+ iseq($count,3,"expect 3 with *MARK:a)b?(*MARK:b)(*SKIP:a)");
local $_='aaabaaab';
$count=0;
our @res=();
- 1 while /(a*(*MARK:a)b?)(*MARK)(*CUT:a)(?{$count++; push @res,$1})(*FAIL)/g;
- iseq($count,5,"Expect 5 with (*MARK:a)b?)(*MARK)(*CUT:a)" );
- iseq("@res","aaab b aaab b ","adjacent (*MARK:a)b?)(*MARK)(*CUT:a) works as expected" );
+ 1 while /(a*(*MARK:a)b?)(*MARK:x)(*SKIP:a)(?{$count++; push @res,$1})(*FAIL)/g;
+ iseq($count,5,"Expect 5 with (*MARK:a)b?)(*MARK:x)(*SKIP:a)" );
+ iseq("@res","aaab b aaab b ","adjacent (*MARK:a)b?)(*MARK:x)(*SKIP:a) works as expected" );
}
{ # Test the (*COMMIT) pattern
our $count = 0;
our $REGERROR;
for my $name ('',':foo')
{
- for my $pat ("(*NOMATCH$name)","(*MARK$name)(*CUT)",
- "(*CUT$name)","(*COMMIT$name)")
+ for my $pat ("(*PRUNE$name)",
+ ($name? "(*MARK$name)" : "")
+ . "(*SKIP$name)",
+ "(*COMMIT$name)")
{
for my $suffix ('(*FAIL)','')
{
our $REGERROR;
for my $name ('',':foo')
{
- for my $pat ("(*NOMATCH$name)","(*MARK$name)(*CUT)",
- "(*CUT$name)","(*COMMIT$name)")
+ for my $pat ("(*PRUNE$name)",
+ ($name? "(*MARK$name)" : "")
+ . "(*SKIP$name)",
+ "(*COMMIT$name)")
{
for my $suffix ('(*FAIL)','')
{
}
{
# Test named commits and the $REGERROR var
+ local $Message = "\$REGERROR";
our $REGERROR;
for $word (qw(bar baz bop)) {
$REGERROR="";
}
}
{ #Regression test for perlbug 40684
+ local $Message = "RT#40684 tests:";
my $s = "abc\ndef";
my $rex = qr'^abc$'m;
ok($s =~ m/$rex/);
ok($s =~ m/^abc$/m);
}
-#-------------------------------------------------------------------
+{
+ #Mindnumbingly simple test of (*THEN)
+ for ("ABC","BAX") {
+ ok(/A (*THEN) X | B (*THEN) C/x,"Simple (*THEN) test");
+ }
+}
+
+{
+ local $Message = "Relative Recursion";
+ my $parens=qr/(\((?:[^()]++|(?-1))*+\))/;
+ local $_='foo((2*3)+4-3) + bar(2*(3+4)-1*(2-3))';
+ my ($all,$one,$two)=('','','');
+ if (/foo $parens \s* \+ \s* bar $parens/x) {
+ $all=$&;
+ $one=$1;
+ $two=$2;
+ }
+ iseq($one, '((2*3)+4-3)');
+ iseq($two, '(2*(3+4)-1*(2-3))');
+ iseq($all, 'foo((2*3)+4-3) + bar(2*(3+4)-1*(2-3))');
+ iseq($all, $_);
+}
+{
+ my $spaces=" ";
+ local $_=join 'bar',$spaces,$spaces;
+ our $count=0;
+ s/(?>\s+bar)(?{$count++})//g;
+ iseq($_,$spaces,"SUSPEND final string");
+ iseq($count,1,"Optimiser should have prevented more than one match");
+}
+{
+ local $Message = "RT#36909 test";
+ $^R = 'Nothing';
+ {
+ local $^R = "Bad";
+ ok('x foofoo y' =~ m{
+ (foo) # $^R correctly set
+ (?{ "last regexp code result" })
+ }x);
+ iseq($^R,'last regexp code result');
+ }
+ iseq($^R,'Nothing');
+ {
+ local $^R = "Bad";
+
+ ok('x foofoo y' =~ m{
+ (?:foo|bar)+ # $^R correctly set
+ (?{"last regexp code result"})
+ }x);
+ iseq($^R,'last regexp code result');
+ }
+ iseq($^R,'Nothing');
+ {
+ local $^R = "Bad";
+ ok('x foofoo y' =~ m{
+ (foo|bar)\1+ # $^R undefined
+ (?{"last regexp code result"})
+ }x);
+ iseq($^R,'last regexp code result');
+ }
+ iseq($^R,'Nothing');
+}
+{
+ local $Message="RT#22395";
+ 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)");
+ }
+}
+{
+ local $Message = "RT#22614";
+ local $_='ab';
+ our @len=();
+ /(.){1,}(?{push @len,0+@-})(.){1,}(?{})^/;
+ iseq("@len","2 2 2");
+}
+{
+ local $Message = "RT#18209";
+ my $text = ' word1 word2 word3 word4 word5 word6 ';
+
+ my @words = ('word1', 'word3', 'word5');
+ my $count;
+ foreach my $word (@words){
+ $text =~ s/$word\s//gi; # Leave a space to seperate words in the resultant str.
+ # The following block is not working.
+ if($&){
+ $count++;
+ }
+ # End bad block
+ }
+ iseq($count,3);
+ iseq($text,' word2 word4 word6 ');
+}
+{
+ # RT#6893
+ local $_= qq(A\nB\nC\n);
+ my @res;
+ while (m#(\G|\n)([^\n]*)\n#gsx)
+ {
+ push @res,"$2";
+ last if @res>3;
+ }
+ iseq("@res","A B C","RT#6893: /g pattern shouldn't infinite loop");
+}
+
+{
+ # From Message-ID: <877ixs6oa6.fsf@k75.linux.bogus>
+ my $dow_name= "nada";
+ my $parser = "(\$dow_name) = \$time_string =~ /(D\x{e9}\\ C\x{e9}adaoin|D\x{e9}\\ Sathairn|\\w+|\x{100})/";
+ my $time_string = "D\x{e9} C\x{e9}adaoin";
+ eval $parser;
+ ok(!$@,"Test Eval worked");
+ iseq($dow_name,$time_string,"UTF8 trie common prefix extraction");
+}
+
+{
+ my $v;
+ ($v='bar')=~/(\w+)/g;
+ $v='foo';
+ iseq("$1",'bar','$1 is safe after /g - may fail due to specialized config in pp_hot.c')
+}
+{
+ local $Message = "http://nntp.perl.org/group/perl.perl5.porters/118663";
+ my $qr_barR1 = qr/(bar)\g-1/;
+ ok("foobarbarxyz" =~ $qr_barR1);
+ ok("foobarbarxyz" =~ qr/foo${qr_barR1}xyz/);
+ ok("foobarbarxyz" =~ qr/(foo)${qr_barR1}xyz/);
+ ok("foobarbarxyz" =~ qr/(foo)(bar)\g{-1}xyz/);
+ ok("foobarbarxyz" =~ qr/(foo${qr_barR1})xyz/);
+ ok("foobarbarxyz" =~ qr/(foo(bar)\g{-1})xyz/);
+}
+{
+ local $Message = "RT#41010";
+ my @tails=('','(?(1))','(|)','()?');
+ my @quants=('*','+');
+ my $doit=sub {
+ my $pats= shift;
+ for (@_) {
+ for my $pat (@$pats) {
+ for my $quant (@quants) {
+ for my $tail (@tails) {
+ my $re = "($pat$quant\$)$tail";
+ ok(/$re/ && $1 eq $_,"'$_'=~/$re/");
+ ok(/$re/m && $1 eq $_,"'$_'=~/$re/m");
+ }
+ }
+ }
+ }
+ };
+
+ my @dpats=(
+ '\d',
+ '[1234567890]',
+ '(1|[23]|4|[56]|[78]|[90])',
+ '(?:1|[23]|4|[56]|[78]|[90])',
+ '(1|2|3|4|5|6|7|8|9|0)',
+ '(?:1|2|3|4|5|6|7|8|9|0)',
+ );
+ my @spats=('[ ]',' ','( |\t)','(?: |\t)','[ \t]','\s');
+ my @sstrs=(' ');
+ my @dstrs=('12345');
+ $doit->(\@spats,@sstrs);
+ $doit->(\@dpats,@dstrs);
+}
+{
+ local $Message = "\$REGMARK";
+ our @r=();
+ ok('foofoo' =~ /foo (*MARK:foo) (?{push @r,$REGMARK}) /x);
+ iseq("@r","foo");
+ iseq($REGMARK,"foo");
+ ok('foofoo' !~ /foo (*MARK:foo) (*FAIL) /x);
+ ok(!$REGMARK);
+ iseq($REGERROR,'foo');
+}
+{
+ my $x;
+ $x = "abc.def.ghi.jkl";
+ $x =~ s/.*\K\..*//;
+ ok($x eq "abc.def.ghi");
+
+ $x = "one two three four";
+ $x =~ s/o+ \Kthree//g;
+ ok($x eq "one two four");
+
+ $x = "abcde";
+ $x =~ s/(.)\K/$1/g;
+ ok($x eq "aabbccddee");
+}
+sub kt
+{
+ return '4' if $_[0] eq '09028623';
+}
+
+{ # Nested EVAL using PL_curpm (via $1 or friends)
+ my $re;
+ our $grabit = qr/ ([0-6][0-9]{7}) (??{ kt $1 }) [890] /x;
+ $re = qr/^ ( (??{ $grabit }) ) $ /x;
+ my @res = '0902862349' =~ $re;
+ iseq(join("-",@res),"0902862349",
+ 'PL_curpm is set properly on nested eval');
+
+ our $qr = qr/ (o) (??{ $1 }) /x;
+ ok( 'boob'=~/( b (??{ $qr }) b )/x && 1,
+ "PL_curpm, nested eval");
+}
+
+{
+ use charnames ":full";
+ ok("\N{ROMAN NUMERAL ONE}" =~ /\p{Alphabetic}/, "I =~ Alphabetic");
+ ok("\N{ROMAN NUMERAL ONE}" =~ /\p{Uppercase}/, "I =~ Uppercase");
+ ok("\N{ROMAN NUMERAL ONE}" !~ /\p{Lowercase}/, "I !~ Lowercase");
+ ok("\N{ROMAN NUMERAL ONE}" =~ /\p{IDStart}/, "I =~ ID_Start");
+ ok("\N{ROMAN NUMERAL ONE}" =~ /\p{IDContinue}/, "I =~ ID_Continue");
+ ok("\N{SMALL ROMAN NUMERAL ONE}" =~ /\p{Alphabetic}/, "i =~ Alphabetic");
+ ok("\N{SMALL ROMAN NUMERAL ONE}" !~ /\p{Uppercase}/, "i !~ Uppercase");
+ ok("\N{SMALL ROMAN NUMERAL ONE}" =~ /\p{Lowercase}/, "i =~ Lowercase");
+ ok("\N{SMALL ROMAN NUMERAL ONE}" =~ /\p{IDStart}/, "i =~ ID_Start");
+ ok("\N{SMALL ROMAN NUMERAL ONE}" =~ /\p{IDContinue}/, "i =~ ID_Continue");
+}
+
+{
+# requirement of Unicode Technical Standard #18, 1.7 Code Points
+# cf. http://www.unicode.org/reports/tr18/#Supplementary_Characters
+ for my $u (0x7FF, 0x800, 0xFFFF, 0x10000) {
+ no warnings 'utf8'; # oops
+ my $c = chr $u;
+ my $x = sprintf '%04X', $u;
+ ok( "A${c}B" =~ /A[\0-\x{10000}]B/, "unicode range - $x");
+ }
+}
+
+
+# Test counter is at bottom of file. Put new tests above here.
+#-------------------------------------------------------------------
# Keep the following tests last -- they may crash perl
+{
+ # RT#19049 / RT#38869
+ my @list = (
+ 'ab cdef', # matches regex
+ ( 'e' x 40000 ) .'ab c' # matches not, but 'ab c' matches part of it
+ );
+ my $y;
+ my $x;
+ foreach (@list) {
+ m/ab(.+)cd/i; # the ignore-case seems to be important
+ $y = $1; # use $1, which might not be from the last match!
+ $x = substr($list[0],$-[0],$+[0]-$-[0]);
+ }
+ iseq($y,' ',
+ 'pattern in a loop, failure should not affect previous success');
+ iseq($x,'ab cd',
+ 'pattern in a loop, failure should not affect previous success');
+}
ok(("a" x (2**15 - 10)) =~ /^()(a|bb)*$/, "Recursive stack cracker: #24274")
or print "# Unexpected outcome: should pass or crash perl\n";
"Regexp /^(??{'(.)'x 100})/ crashes older perls")
or print "# Unexpected outcome: should pass or crash perl\n";
+eval '/\k/';
+ok($@=~/\QSequence \k... not terminated in regex;\E/);
+
{
+ local $Message = "substitution with lookahead (possible segv)";
$_="ns1ns1ns1";
s/ns(?=\d)/ns_/g;
iseq($_,"ns_1ns_1ns_1");
iseq($_,"!Bang!1!Bang!2!Bang!3!Bang!");
}
-# Put new tests above the line, not here.
-
+# Put new tests above the dotted line about a page above this comment
+iseq(0+$::test,$::TestCount,"Got the right number of tests!");
# Don't forget to update this!
-BEGIN{print "1..1347\n"};
+BEGIN {
+ $::TestCount = 1636;
+ print "1..$::TestCount\n";
+}
https://perl5.git.perl.org / perl5.git / blobdiff