1#!./perl 2 3# This tests (?[...]). XXX These are just basic tests, as full ones would be 4# best done with an infrastructure change to allow getting out the inversion 5# list of the constructed set and then comparing it character by character 6# with the expected result. 7 8BEGIN { 9 chdir 't' if -d 't'; 10 require './test.pl'; 11 set_up_inc( '../lib','.','../ext/re' ); 12 require './charset_tools.pl'; 13 require './loc_tools.pl'; 14} 15 16skip_all_without_unicode_tables(); 17 18use strict; 19use warnings; 20 21$| = 1; 22 23use utf8; 24 25like("a", qr/(?[ [a] # This is a comment 26 ])/, 'Can ignore a comment'); 27like("a", qr/(?[ [a] # [[:notaclass:]] 28 ])/, 'A comment isn\'t parsed'); 29unlike(uni_to_native("\x85"), qr/(?[ \t… ])/, 'NEL is white space'); 30like(uni_to_native("\x85"), qr/(?[ \t + \… ])/, 'can escape NEL to match'); 31like(uni_to_native("\x85"), qr/(?[ [\…] ])/, '... including within nested []'); 32like("\t", qr/(?[ \t + \… ])/, 'can do basic union'); 33like("\cK", qr/(?[ \s ])/, '\s matches \cK'); 34unlike("\cK", qr/(?[ \s - \cK ])/, 'can do basic subtraction'); 35like(" ", qr/(?[ \s - \cK ])/, 'can do basic subtraction'); 36like(":", qr/(?[ [:] ])/, '[:] is not a posix class'); 37unlike("\t", qr/(?[ ! \t ])/, 'can do basic complement'); 38like("\t", qr/(?[ ! [ ^ \t ] ])/, 'can do basic complement'); 39unlike("\r", qr/(?[ \t ])/, '\r doesn\'t match \t '); 40like("\r", qr/(?[ ! \t ])/, 'can do basic complement'); 41like("0", qr/(?[ [:word:] & [:digit:] ])/, 'can do basic intersection'); 42unlike("A", qr/(?[ [:word:] & [:digit:] ])/, 'can do basic intersection'); 43like("0", qr/(?[[:word:]&[:digit:]])/, 'spaces around internal [] aren\'t required'); 44 45like("a", qr/(?[ [a] | [b] ])/, '| means union'); 46like("b", qr/(?[ [a] | [b] ])/, '| means union'); 47unlike("c", qr/(?[ [a] | [b] ])/, '| means union'); 48 49like("a", qr/(?[ [ab] ^ [bc] ])/, 'basic symmetric difference works'); 50unlike("b", qr/(?[ [ab] ^ [bc] ])/, 'basic symmetric difference works'); 51like("c", qr/(?[ [ab] ^ [bc] ])/, 'basic symmetric difference works'); 52 53like("2", qr/(?[ ( ( \pN & ( [a] + [2] ) ) ) ])/, 'Nesting parens and grouping'); 54unlike("a", qr/(?[ ( ( \pN & ( [a] + [2] ) ) ) ])/, 'Nesting parens and grouping'); 55 56unlike("\x{17f}", qr/(?[ [k] + \p{Blk=ASCII} ])/i, '/i doesn\'t affect \p{}'); 57like("\N{KELVIN SIGN}", qr/(?[ [k] + \p{Blk=ASCII} ])/i, '/i does affect literals'); 58 59my $thai_or_lao = qr/(?[ \p{Thai} + \p{Lao} ])/; 60my $thai_or_lao_digit = qr/(?[ \p{Digit} & $thai_or_lao ])/; 61like("\N{THAI DIGIT ZERO}", $thai_or_lao_digit, 'embedded qr/(?[ ])/ works'); 62unlike(chr(ord("\N{THAI DIGIT ZERO}") - 1), $thai_or_lao_digit, 'embedded qr/(?[ ])/ works'); 63like("\N{THAI DIGIT NINE}", $thai_or_lao_digit, 'embedded qr/(?[ ])/ works'); 64unlike(chr(ord("\N{THAI DIGIT NINE}") + 1), $thai_or_lao_digit, 'embedded qr/(?[ ])/ works'); 65like("\N{LAO DIGIT ZERO}", $thai_or_lao_digit, 'embedded qr/(?[ ])/ works'); 66unlike(chr(ord("\N{LAO DIGIT ZERO}") - 1), $thai_or_lao_digit, 'embedded qr/(?[ ])/ works'); 67like("\N{LAO DIGIT NINE}", $thai_or_lao_digit, 'embedded qr/(?[ ])/ works'); 68unlike(chr(ord("\N{LAO DIGIT NINE}") + 1), $thai_or_lao_digit, 'embedded qr/(?[ ])/ works'); 69 70my $ascii_word = qr/(?[ \w ])/a; 71my $ascii_digits_plus_all_of_arabic = qr/(?[ \p{Arabic} + \p{Digit} & $ascii_word ])/; 72like("9", $ascii_digits_plus_all_of_arabic, "/a, then interpolating and intersection works for ASCII in the set"); 73unlike("A", $ascii_digits_plus_all_of_arabic, "/a, then interpolating and intersection works for ASCII not in the set"); 74unlike("\N{BENGALI DIGIT ZERO}", $ascii_digits_plus_all_of_arabic, "/a, then interpolating and intersection works for non-ASCII not in either set"); 75unlike("\N{BENGALI LETTER A}", $ascii_digits_plus_all_of_arabic, "/a, then interpolating and intersection works for non-ASCII in one set"); 76like("\N{ARABIC LETTER HAMZA}", $ascii_digits_plus_all_of_arabic, "intersection has higher precedence than union"); 77like("\N{EXTENDED ARABIC-INDIC DIGIT ZERO}", $ascii_digits_plus_all_of_arabic, "intersection has higher precedence than union"); 78 79like("\r", qr/(?[ \p{lb=cr} ])/, '\r matches \p{lb=cr}'); 80unlike("\r", qr/(?[ ! \p{lb=cr} ])/, '\r doesnt match ! \p{lb=cr}'); 81like("\r", qr/(?[ ! ! \p{lb=cr} ])/, 'Two ! ! are the original'); 82unlike("\r", qr/(?[ ! ! ! \p{lb=cr} ])/, 'Three ! ! ! are the complement'); 83# left associatve 84 85my $kelvin = qr/(?[ \N{KELVIN SIGN} ])/; 86my $fold = qr/(?[ $kelvin ])/i; 87like("\N{KELVIN SIGN}", $kelvin, '"\N{KELVIN SIGN}" matches compiled qr/(?[ \N{KELVIN SIGN} ])/'); 88unlike("K", $fold, "/i on outer (?[ ]) doesn't leak to interpolated one"); 89unlike("k", $fold, "/i on outer (?[ ]) doesn't leak to interpolated one"); 90 91my $kelvin_fold = qr/(?[ \N{KELVIN SIGN} ])/i; 92my $still_fold = qr/(?[ $kelvin_fold ])/; 93like("K", $still_fold, "/i on interpolated (?[ ]) is retained in outer without /i"); 94like("k", $still_fold, "/i on interpolated (?[ ]) is retained in outer without /i"); 95 96eval 'my $x = qr/(?[ [a] ])/; qr/(?[ $x ])/'; 97is($@, "", 'qr/(?[ [a] ])/ can be interpolated'); 98 99like("B", qr/(?[ [B] | ! ( [^B] ) ])/, "[perl #125892]"); 100 101like("a", qr/(?[ (?#comment) [a]])/, "Can have (?#comments)"); 102 103if (! is_miniperl() && locales_enabled('LC_CTYPE')) { 104 my $utf8_locale = find_utf8_ctype_locale; 105 SKIP: { 106 skip("No LC_ALL on this platform", 8) unless locales_enabled('LC_ALL'); 107 skip("No utf8 locale available on this platform", 8) unless $utf8_locale; 108 109 setlocale(&POSIX::LC_ALL, "C"); 110 use locale; 111 112 $kelvin_fold = qr/(?[ \N{KELVIN SIGN} ])/i; 113 my $single_char_class = qr/(?[ \: ])/; 114 115 setlocale(&POSIX::LC_ALL, $utf8_locale); 116 117 like("\N{KELVIN SIGN}", $kelvin_fold, 118 '(?[ \N{KELVIN SIGN} ]) matches itself under /i in UTF8-locale'); 119 like("K", $kelvin_fold, 120 '(?[ \N{KELVIN SIGN} ]) matches "K" under /i in UTF8-locale'); 121 like("k", $kelvin_fold, 122 '(?[ \N{KELVIN SIGN} ]) matches "k" under /i in UTF8-locale'); 123 like(":", $single_char_class, 124 '(?[ : ]) matches itself in UTF8-locale (a single character class)'); 125 126 setlocale(&POSIX::LC_ALL, "C"); 127 128 # These should generate warnings (the above 4 shouldn't), but like() 129 # suppresses them, so the warnings tests are in t/lib/warnings/regexec 130 $^W = 0; # Suppress the warnings that occur when run by hand with 131 # the -w option 132 like("\N{KELVIN SIGN}", $kelvin_fold, 133 '(?[ \N{KELVIN SIGN} ]) matches itself under /i in C locale'); 134 like("K", $kelvin_fold, 135 '(?[ \N{KELVIN SIGN} ]) matches "K" under /i in C locale'); 136 like("k", $kelvin_fold, 137 '(?[ \N{KELVIN SIGN} ]) matches "k" under /i in C locale'); 138 like(":", $single_char_class, 139 '(?[ : ]) matches itself in C locale (a single character class)'); 140 } 141} 142 143# Tests that no warnings given for valid Unicode digit range. 144my $arabic_digits = qr/(?[ [ ٠ - ٩ ] ])/; 145for my $char ("٠", "٥", "٩") { 146 use charnames (); 147 my @got = capture_warnings(sub { 148 like("٠", $arabic_digits, "Matches " 149 . charnames::viacode(ord $char)); 150 }); 151 is (@got, 0, "... without warnings"); 152} 153 154# RT #126181: \cX behaves strangely inside (?[]) 155{ 156 no warnings qw(syntax regexp); 157 158 eval { $_ = '/(?[(\c]) /'; qr/$_/ }; 159 like($@, qr/^Syntax error/, '/(?[(\c]) / should not panic'); 160 eval { $_ = '(?[\c#]' . "\n])"; qr/$_/ }; 161 like($@, qr/^Unexpected/, '/(?[(\c]) / should not panic'); 162 eval { $_ = '(?[(\c])'; qr/$_/ }; 163 like($@, qr/^Syntax error/, '/(?[(\c])/ should be a syntax error'); 164 eval { $_ = '(?[(\c]) ]\b'; qr/$_/ }; 165 like($@, qr/^Unexpected/, '/(?[(\c]) ]\b/ should be a syntax error'); 166 eval { $_ = '(?[\c[]](])'; qr/$_/ }; 167 like($@, qr/^Unexpected/, '/(?[\c[]](])/ should be a syntax error'); 168 like("\c#", qr/(?[\c#])/, '\c# should match itself'); 169 like("\c[", qr/(?[\c[])/, '\c[ should match itself'); 170 like("\c\ ", qr/(?[\c\])/, '\c\ should match itself'); 171 like("\c]", qr/(?[\c]])/, '\c] should match itself'); 172} 173 174# RT #126481 !! with syntax error panics 175{ 176 fresh_perl_like('qr/(?[ ! ! (\w])/', 177 qr/^Unmatched \(/, {}, 178 'qr/(?[ ! ! (\w])/ doesnt panic'); 179 180 # The following didn't panic before, but easy to add this here with a 181 # paren between the !! 182 fresh_perl_like('qr/(?[ ! ( ! (\w)])/', 183 qr/^Unmatched \(/, {}, 184 'qr/qr/(?[ ! ( ! (\w)])/'); 185} 186 187{ # RT #129122 188 my $pat = '(?[ ( [ABC] - [B] ) + ( [abc] - [b] ) + [def] ])'; 189 like("A", qr/$pat/, "'A' matches /$pat/"); 190 unlike("B", qr/$pat/, "'B' doesn't match /$pat/"); 191 like("C", qr/$pat/, "'C' matches /$pat/"); 192 unlike("D", qr/$pat/, "'D' doesn't match /$pat/"); 193 like("a", qr/$pat/, "'a' matches /$pat/"); 194 unlike("b", qr/$pat/, "'b' doesn't match /$pat/"); 195 like("c", qr/$pat/, "'c' matches /$pat/"); 196 like("d", qr/$pat/, "'d' matches /$pat/"); 197 like("e", qr/$pat/, "'e' matches /$pat/"); 198 like("f", qr/$pat/, "'f' matches /$pat/"); 199 unlike("g", qr/$pat/, "'g' doesn't match /$pat/"); 200} 201 202{ # [perl #129322 ] This crashed perl, so keep after the ones that don't 203 my $pat = '(?[[!]&[0]^[!]&[0]+[a]])'; 204 like("a", qr/$pat/, "/$pat/ compiles and matches 'a'"); 205} 206 207{ # [perl #132167] 208 fresh_perl_is( 209 'print "c" =~ qr/(?[ ( \p{Uppercase} ) + (\p{Lowercase} - ([a] + [b])) ])/;', 210 1, {}, 211 'qr/(?[ ( \p{Uppercase} ) + (\p{Lowercase} - ([a] + [b])) ]) compiles and properly matches'); 212 fresh_perl_is( 213 'print "b" =~ qr/(?[ ( \p{Uppercase} ) + (\p{Lowercase} - ([a] + [b])) ])/;', 214 "", {}, 215 'qr/(?[ ( \p{Uppercase} ) + (\p{Lowercase} - ([a] + [b])) ]) compiles and properly matches'); 216} 217 218{ # [perl #133889] Caused assertion failure 219 fresh_perl_like( 220 'qr/(?[\P{Is0}])/', qr/\QUnknown user-defined property name "Is0"/, {}, "[perl #133889]"); 221} 222 223{ 224 my $s = qr/(?x:(?[ [ x ] ]))/; 225 like("x", qr/(?[ $s ])/ , "Modifier flags in interpolated set don't" 226 . " disrupt"); 227} 228 229{ # GH #16779 230 like("x", qr/(?[ (?^x:(?[ [x] ])) ])/ , 231 "Can use '^' flag in a nested call"); 232 like("x", qr/(?[ (?x-imns:(?[ [x] ])) ])/ , 233 "Can use various flags in a nested call"); 234} 235 236done_testing(); 237 2381; 239