}
-
+print "# set PERL_SKIP_PSYCHO_TEST to skip this test\n";
if (!$ENV{PERL_SKIP_PSYCHO_TEST}){
my @normal=qw(these are some normal words);
my $psycho=join "|",@normal,map chr $_,255..20000;
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");
}
if ($ENV{PERL_SKIP_PSYCHO_TEST}){
printf "ok %d Skip: No psycho tests\n", $test++;
} else {
+ print "# set PERL_SKIP_PSYCHO_TEST to skip this test\n";
my $r = qr/^
(?:
( (?:a|z+)+ )
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 \\v");
- $count = 0;
- 'aaab'=~/a+b?\v(?{$count++})(*FAIL)/;
- iseq($count,3,"expect 3 with \\v");
- local $_='aaab';
- $count=0;
- 1 while /.\v(?{$count++})(*FAIL)/g;
- iseq($count,4,"/.\\v/");
- $count = 0;
- 'aaab'=~/a+b?(??{'\v'})(?{$count++})(*FAIL)/;
- iseq($count,3,"expect 3 with \\v");
- local $_='aaab';
- $count=0;
- 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,2,"Expect 2 with (*SKIP)" );
iseq("@res","aaab aaab","adjacent (*SKIP) works as expected" );
}
-{ # Test the \V form of the (*SKIP) pattern
- our $count = 0;
- 'aaab'=~/a+b?\V(?{$count++})(*FAIL)/;
- iseq($count,1,"expect 1 with \\V");
- local $_='aaab';
- $count=0;
- 1 while /.\V(?{$count++})(*FAIL)/g;
- iseq($count,4,"/.\\V/");
- $_='aaabaaab';
- $count=0;
- our @res=();
- 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 (*SKIP) pattern
our $count = 0;
'aaab'=~/a+b?(*MARK:foo)(*SKIP)(?{$count++})(*FAIL)/;
iseq("$1$2",'foooooobaaaaar');
}
iseq("$1$2","foobar");
+}
+{
+ local $Message = "HORIZWS";
+ local $_="\t \r\n \n \t".chr(11)."\n";
+ s/\H/H/g;
+ s/\h/h/g;
+ iseq($_,"hhHHhHhhHH");
+ $_="\t \r\n \n \t".chr(11)."\n";
+ utf8::upgrade($_);
+ s/\H/H/g;
+ s/\h/h/g;
+ iseq($_,"hhHHhHhhHH");
}
+{
+ local $Message = "Various whitespace special patterns";
+ my @h=map { chr( $_ ) } (
+ 0x09, 0x20, 0xa0, 0x1680, 0x180e, 0x2000, 0x2001, 0x2002,
+ 0x2003, 0x2004, 0x2005, 0x2006, 0x2007, 0x2008, 0x2009, 0x200a,
+ 0x202f, 0x205f, 0x3000
+ );
+ my @v=map { chr( $_ ) } ( 0x0a, 0x0b, 0x0c, 0x0d, 0x85, 0x2028, 0x2029 );
+ my @lb=( "\x0D\x0A",
+ map { chr( $_ ) } ( 0x0A..0x0D,0x85,0x2028,0x2029 ));
+ foreach my $t ([\@h,qr/\h/,qr/\h+/],[\@v,qr/\v/,qr/\v+/],[\@lb,qr/\R/,qr/\R+/],){
+ my $ary=shift @$t;
+ foreach my $pat (@$t) {
+ foreach my $str (@$ary) {
+ ok($str=~/($pat)/,$pat);
+ iseq($1,$str,$pat);
+ utf8::upgrade($str);
+ ok($str=~/($pat)/,"Upgraded string - $pat");
+ iseq($1,$str,"Upgraded string - $pat");
+ }
+ }
+ }
+}
+{
+ local $Message = "Check that \\xDF match properly in its various forms";
+ # test that \xDF matches properly. this is pretty hacky stuff,
+ # but its actually needed. the malarky with '-' is to prevent
+ # compilation caching from playing any role in the test.
+ my @df= (chr(0xDF),'-',chr(0xDF));
+ utf8::upgrade($df[2]);
+ my @strs= ('ss','sS','Ss','SS',chr(0xDF));
+ my @ss= map { ("$_", "$_") } @strs;
+ utf8::upgrade($ss[$_*2+1]) for 0..$#strs;
+
+ for my $ssi (0..$#ss) {
+ for my $dfi (0..$#df) {
+ my $pat= $df[$dfi];
+ my $str= $ss[$ssi];
+ my $utf_df= ($dfi > 1) ? 'utf8' : '';
+ my $utf_ss= ($ssi % 2) ? 'utf8' : '';
+ (my $sstr=$str)=~s/\xDF/\\xDF/;
+
+ if ($utf_df || $utf_ss || length($ss[$ssi])==1) {
+ my $ret= $str=~/$pat/i;
+ next if $pat eq '-';
+ ok($ret,
+ "\"$sstr\"=~/\\xDF/i (str is @{[$utf_ss||'latin']}, pat is @{[$utf_df||'latin']})");
+ } else {
+ my $ret= $str !~ /$pat/i;
+ next if $pat eq '-';
+ ok($ret,
+ "\"$sstr\"!~/\\xDF/i (str is @{[$utf_ss||'latin']}, pat is @{[$utf_df||'latin']})");
+ }
+ }
+ }
+}
+{
+ local $Message = "BBC(Bleadperl Breaks CPAN) Today: String::Multibyte";
+ my $re = qr/(?:[\x00-\xFF]{4})/;
+ my $hyp = "\0\0\0-";
+ my $esc = "\0\0\0\\";
+
+ my $str = "$esc$hyp$hyp$esc$esc";
+ my @a = ($str =~ /\G(?:\Q$esc$esc\E|\Q$esc$hyp\E|$re)/g);
+
+ iseq(0+@a,3);
+ iseq(join('=', @a),"$esc$hyp=$hyp=$esc$esc");
+}
+# test for keys in %+ and %-
+{
+ my $_ = "abcdef";
+ /(?<foo>a)|(?<foo>b)/;
+ iseq( (join ",", sort keys %+), "foo" );
+ iseq( (join ",", sort keys %-), "foo" );
+ iseq( (join ",", sort values %+), "a" );
+ iseq( (join ",", sort map "@$_", values %-), "a " );
+ /(?<bar>a)(?<bar>b)(?<quux>.)/;
+ iseq( (join ",", sort keys %+), "bar,quux" );
+ iseq( (join ",", sort keys %-), "bar,quux" );
+ iseq( (join ",", sort values %+), "a,c" ); # leftmost
+ iseq( (join ",", sort map "@$_", values %-), "a b,c" );
+ /(?<un>a)(?<deux>c)?/; # second buffer won't capture
+ iseq( (join ",", sort keys %+), "un" );
+ iseq( (join ",", sort keys %-), "deux,un" );
+ iseq( (join ",", sort values %+), "a" );
+ iseq( (join ",", sort map "@$_", values %-), ",a" );
+}
+
+# length() on captures, the numbered ones end up in Perl_magic_len
+{
+ my $_ = "aoeu \xe6var ook";
+ /^ \w+ \s (?<eek>\S+)/x;
+
+ iseq( length($`), 0, 'length $`' );
+ iseq( length($'), 4, q[length $'] );
+ iseq( length($&), 9, 'length $&' );
+ iseq( length($1), 4, 'length $1' );
+ iseq( length($+{eek}), 4, 'length $+{eek} == length $1' );
+}
+
+{
+ my $ok=-1;
+
+ $ok=exists($-{x}) ? 1 : 0
+ if 'bar'=~/(?<x>foo)|bar/;
+ iseq($ok,1,'$-{x} exists after "bar"=~/(?<x>foo)|bar/');
+ iseq(scalar(%+), 0, 'scalar %+ == 0 after "bar"=~/(?<x>foo)|bar/');
+ iseq(scalar(%-), 1, 'scalar %- == 1 after "bar"=~/(?<x>foo)|bar/');
+
+ $ok=-1;
+ $ok=exists($+{x}) ? 1 : 0
+ if 'bar'=~/(?<x>foo)|bar/;
+ iseq($ok,0,'$+{x} not exists after "bar"=~/(?<x>foo)|bar/');
+ iseq(scalar(%+), 0, 'scalar %+ == 0 after "bar"=~/(?<x>foo)|bar/');
+ iseq(scalar(%-), 1, 'scalar %- == 1 after "bar"=~/(?<x>foo)|bar/');
+
+ $ok=-1;
+ $ok=exists($-{x}) ? 1 : 0
+ if 'foo'=~/(?<x>foo)|bar/;
+ iseq($ok,1,'$-{x} exists after "foo"=~/(?<x>foo)|bar/');
+ iseq(scalar(%+), 1, 'scalar %+ == 1 after "foo"=~/(?<x>foo)|bar/');
+ iseq(scalar(%-), 1, 'scalar %- == 1 after "foo"=~/(?<x>foo)|bar/');
+
+ $ok=-1;
+ $ok=exists($+{x}) ? 1 : 0
+ if 'foo'=~/(?<x>foo)|bar/;
+ iseq($ok,1,'$+{x} exists after "foo"=~/(?<x>foo)|bar/');
+}
+{
+ local $_;
+ ($_ = 'abc')=~/(abc)/g;
+ $_ = '123';
+ iseq("$1",'abc',"/g leads to unsafe match vars: $1");
+}
+{
+ local $Message="Message-ID: <20070818091501.7eff4831@r2d2>";
+ my $str= "";
+ for(0..5){
+ my @x;
+ $str .= "@x"; # this should ALWAYS be the empty string
+ 'a'=~/(a|)/;
+ push @x,1;
+ }
+ iseq(length($str),"0","Trie scope error, string should be empty");
+ $str="";
+ my @foo = ('a')x5;
+ for (@foo) {
+ my @bar;
+ $str .= "@bar";
+ s/a|/push @bar, 1/e;
+ }
+ 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");
+ }
+ }
+ }
+}
+
# Test counter is at bottom of file. Put new tests above here.
#-------------------------------------------------------------------
# Keep the following tests last -- they may crash perl
iseq($_,"!Bang!1!Bang!2!Bang!3!Bang!");
}
-# test for keys in %+ and %-
-{
- my $_ = "abcdef";
- /(?<foo>a)|(?<foo>b)/;
- iseq( (join ",", sort keys %+), "foo" );
- iseq( (join ",", sort keys %-), "foo" );
- iseq( (join ",", sort values %+), "a" );
- iseq( (join ",", sort map "@$_", values %-), "a " );
- /(?<bar>a)(?<bar>b)(?<quux>.)/;
- iseq( (join ",", sort keys %+), "bar,quux" );
- iseq( (join ",", sort keys %-), "bar,quux" );
- iseq( (join ",", sort values %+), "a,c" ); # leftmost
- iseq( (join ",", sort map "@$_", values %-), "a b,c" );
- /(?<un>a)(?<deux>c)?/; # second buffer won't capture
- iseq( (join ",", sort keys %+), "un" );
- iseq( (join ",", sort keys %-), "deux,un" );
- iseq( (join ",", sort values %+), "a" );
- iseq( (join ",", sort map "@$_", values %-), ",a" );
-}
+# [perl #45337] utf8 + "[a]a{2}" + /$.../ = panic: sv_len_utf8 cache
-# length() on captures, these end up in Perl_magic_len
{
- my $_ = "aoeu \xe6var ook";
- /^ \w+ \s (?<eek>\S+)/x;
-
- iseq( length($`), 0, 'length $`' );
- iseq( length($'), 4, q[length $'] );
- iseq( length($&), 9, 'length $&' );
- iseq( length($1), 4, 'length $1' );
- iseq( length($+{eek}), 4, 'length $+{eek} == length $1' );
+ 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!");
# Don't forget to update this!
BEGIN {
- $::TestCount = 1663;
+ $::TestCount = 4013;
print "1..$::TestCount\n";
}
-
projects / p5sagit/p5-mst-13.2.git / blobdiff