Commit | Line | Data |
---|---|---|
8d063cd8 | 1 | #!./perl |
8d37f932 DD |
2 | # |
3 | # This is a home for regular expression tests that don't fit into | |
4 | # the format supported by op/regexp.t. If you want to add a test | |
5 | # that does fit that format, add it to op/re_tests, not here. | |
8d063cd8 | 6 | |
9133bbab | 7 | $| = 1; |
3568d838 | 8 | |
0e788c72 | 9 | print "1..1065\n"; |
8d37f932 | 10 | |
e4d48cc9 GS |
11 | BEGIN { |
12 | chdir 't' if -d 't'; | |
20822f61 | 13 | @INC = '../lib'; |
e4d48cc9 | 14 | } |
ffbc6a93 | 15 | |
8d37f932 | 16 | eval 'use Config'; # Defaults assumed if this fails |
8d063cd8 LW |
17 | |
18 | $x = "abc\ndef\n"; | |
19 | ||
20 | if ($x =~ /^abc/) {print "ok 1\n";} else {print "not ok 1\n";} | |
21 | if ($x !~ /^def/) {print "ok 2\n";} else {print "not ok 2\n";} | |
22 | ||
f02c194e RGS |
23 | # used to be a test for $* |
24 | if ($x =~ /^def/m) {print "ok 3\n";} else {print "not ok 3\n";} | |
8d063cd8 LW |
25 | |
26 | $_ = '123'; | |
27 | if (/^([0-9][0-9]*)/) {print "ok 4\n";} else {print "not ok 4\n";} | |
28 | ||
29 | if ($x =~ /^xxx/) {print "not ok 5\n";} else {print "ok 5\n";} | |
30 | if ($x !~ /^abc/) {print "not ok 6\n";} else {print "ok 6\n";} | |
31 | ||
32 | if ($x =~ /def/) {print "ok 7\n";} else {print "not ok 7\n";} | |
33 | if ($x !~ /def/) {print "not ok 8\n";} else {print "ok 8\n";} | |
34 | ||
35 | if ($x !~ /.def/) {print "ok 9\n";} else {print "not ok 9\n";} | |
36 | if ($x =~ /.def/) {print "not ok 10\n";} else {print "ok 10\n";} | |
37 | ||
38 | if ($x =~ /\ndef/) {print "ok 11\n";} else {print "not ok 11\n";} | |
39 | if ($x !~ /\ndef/) {print "not ok 12\n";} else {print "ok 12\n";} | |
40 | ||
41 | $_ = 'aaabbbccc'; | |
42 | if (/(a*b*)(c*)/ && $1 eq 'aaabbb' && $2 eq 'ccc') { | |
43 | print "ok 13\n"; | |
44 | } else { | |
45 | print "not ok 13\n"; | |
46 | } | |
47 | if (/(a+b+c+)/ && $1 eq 'aaabbbccc') { | |
48 | print "ok 14\n"; | |
49 | } else { | |
50 | print "not ok 14\n"; | |
51 | } | |
52 | ||
53 | if (/a+b?c+/) {print "not ok 15\n";} else {print "ok 15\n";} | |
54 | ||
55 | $_ = 'aaabccc'; | |
56 | if (/a+b?c+/) {print "ok 16\n";} else {print "not ok 16\n";} | |
57 | if (/a*b+c*/) {print "ok 17\n";} else {print "not ok 17\n";} | |
58 | ||
59 | $_ = 'aaaccc'; | |
60 | if (/a*b?c*/) {print "ok 18\n";} else {print "not ok 18\n";} | |
61 | if (/a*b+c*/) {print "not ok 19\n";} else {print "ok 19\n";} | |
62 | ||
63 | $_ = 'abcdef'; | |
64 | if (/bcd|xyz/) {print "ok 20\n";} else {print "not ok 20\n";} | |
65 | if (/xyz|bcd/) {print "ok 21\n";} else {print "not ok 21\n";} | |
66 | ||
67 | if (m|bc/*d|) {print "ok 22\n";} else {print "not ok 22\n";} | |
378cc40b LW |
68 | |
69 | if (/^$_$/) {print "ok 23\n";} else {print "not ok 23\n";} | |
70 | ||
f02c194e RGS |
71 | # used to be a test for $* |
72 | if ("ab\ncd\n" =~ /^cd/m) {print "ok 24\n";} else {print "not ok 24\n";} | |
378cc40b | 73 | |
cb55de95 JH |
74 | $XXX{123} = 123; |
75 | $XXX{234} = 234; | |
76 | $XXX{345} = 345; | |
77 | ||
78 | @XXX = ('ok 25','not ok 25', 'ok 26','not ok 26','not ok 27'); | |
79 | while ($_ = shift(@XXX)) { | |
80 | ?(.*)? && (print $1,"\n"); | |
81 | /not/ && reset; | |
82 | /not ok 26/ && reset 'X'; | |
83 | } | |
84 | ||
85 | while (($key,$val) = each(%XXX)) { | |
86 | print "not ok 27\n"; | |
87 | exit; | |
88 | } | |
89 | ||
90 | print "ok 27\n"; | |
378cc40b | 91 | |
378cc40b LW |
92 | 'cde' =~ /[^ab]*/; |
93 | 'xyz' =~ //; | |
94 | if ($& eq 'xyz') {print "ok 28\n";} else {print "not ok 28\n";} | |
95 | ||
96 | $foo = '[^ab]*'; | |
97 | 'cde' =~ /$foo/; | |
98 | 'xyz' =~ //; | |
99 | if ($& eq 'xyz') {print "ok 29\n";} else {print "not ok 29\n";} | |
100 | ||
101 | $foo = '[^ab]*'; | |
102 | 'cde' =~ /$foo/; | |
103 | 'xyz' =~ /$null/; | |
104 | if ($& eq 'xyz') {print "ok 30\n";} else {print "not ok 30\n";} | |
a687059c LW |
105 | |
106 | $_ = 'abcdefghi'; | |
107 | /def/; # optimized up to cmd | |
108 | if ("$`:$&:$'" eq 'abc:def:ghi') {print "ok 31\n";} else {print "not ok 31\n";} | |
109 | ||
110 | /cde/ + 0; # optimized only to spat | |
111 | if ("$`:$&:$'" eq 'ab:cde:fghi') {print "ok 32\n";} else {print "not ok 32\n";} | |
112 | ||
113 | /[d][e][f]/; # not optimized | |
114 | if ("$`:$&:$'" eq 'abc:def:ghi') {print "ok 33\n";} else {print "not ok 33\n";} | |
115 | ||
116 | $_ = 'now is the {time for all} good men to come to.'; | |
117 | / {([^}]*)}/; | |
118 | if ($1 eq 'time for all') {print "ok 34\n";} else {print "not ok 34 $1\n";} | |
119 | ||
120 | $_ = 'xxx {3,4} yyy zzz'; | |
121 | print /( {3,4})/ ? "ok 35\n" : "not ok 35\n"; | |
122 | print $1 eq ' ' ? "ok 36\n" : "not ok 36\n"; | |
123 | print /( {4,})/ ? "not ok 37\n" : "ok 37\n"; | |
124 | print /( {2,3}.)/ ? "ok 38\n" : "not ok 38\n"; | |
125 | print $1 eq ' y' ? "ok 39\n" : "not ok 39\n"; | |
126 | print /(y{2,3}.)/ ? "ok 40\n" : "not ok 40\n"; | |
127 | print $1 eq 'yyy ' ? "ok 41\n" : "not ok 41\n"; | |
128 | print /x {3,4}/ ? "not ok 42\n" : "ok 42\n"; | |
129 | print /^xxx {3,4}/ ? "not ok 43\n" : "ok 43\n"; | |
352d5a3a LW |
130 | |
131 | $_ = "now is the time for all good men to come to."; | |
132 | @words = /(\w+)/g; | |
133 | print join(':',@words) eq "now:is:the:time:for:all:good:men:to:come:to" | |
134 | ? "ok 44\n" | |
135 | : "not ok 44\n"; | |
136 | ||
137 | @words = (); | |
138 | while (/\w+/g) { | |
139 | push(@words, $&); | |
140 | } | |
141 | print join(':',@words) eq "now:is:the:time:for:all:good:men:to:come:to" | |
142 | ? "ok 45\n" | |
143 | : "not ok 45\n"; | |
144 | ||
145 | @words = (); | |
71be2cbc | 146 | pos = 0; |
352d5a3a LW |
147 | while (/to/g) { |
148 | push(@words, $&); | |
149 | } | |
150 | print join(':',@words) eq "to:to" | |
151 | ? "ok 46\n" | |
71be2cbc | 152 | : "not ok 46 `@words'\n"; |
352d5a3a | 153 | |
71be2cbc | 154 | pos $_ = 0; |
352d5a3a LW |
155 | @words = /to/g; |
156 | print join(':',@words) eq "to:to" | |
157 | ? "ok 47\n" | |
71be2cbc | 158 | : "not ok 47 `@words'\n"; |
352d5a3a LW |
159 | |
160 | $_ = "abcdefghi"; | |
161 | ||
162 | $pat1 = 'def'; | |
163 | $pat2 = '^def'; | |
164 | $pat3 = '.def.'; | |
165 | $pat4 = 'abc'; | |
166 | $pat5 = '^abc'; | |
167 | $pat6 = 'abc$'; | |
168 | $pat7 = 'ghi'; | |
169 | $pat8 = '\w*ghi'; | |
170 | $pat9 = 'ghi$'; | |
171 | ||
172 | $t1=$t2=$t3=$t4=$t5=$t6=$t7=$t8=$t9=0; | |
173 | ||
174 | for $iter (1..5) { | |
175 | $t1++ if /$pat1/o; | |
176 | $t2++ if /$pat2/o; | |
177 | $t3++ if /$pat3/o; | |
178 | $t4++ if /$pat4/o; | |
179 | $t5++ if /$pat5/o; | |
180 | $t6++ if /$pat6/o; | |
181 | $t7++ if /$pat7/o; | |
182 | $t8++ if /$pat8/o; | |
183 | $t9++ if /$pat9/o; | |
184 | } | |
185 | ||
186 | $x = "$t1$t2$t3$t4$t5$t6$t7$t8$t9"; | |
187 | print $x eq '505550555' ? "ok 48\n" : "not ok 48 $x\n"; | |
1462b684 LW |
188 | |
189 | $xyz = 'xyz'; | |
190 | print "abc" =~ /^abc$|$xyz/ ? "ok 49\n" : "not ok 49\n"; | |
191 | ||
192 | # perl 4.009 says "unmatched ()" | |
193 | eval '"abc" =~ /a(bc$)|$xyz/; $result = "$&:$1"'; | |
194 | print $@ eq "" ? "ok 50\n" : "not ok 50\n"; | |
195 | print $result eq "abc:bc" ? "ok 51\n" : "not ok 51\n"; | |
a0d0e21e LW |
196 | |
197 | ||
198 | $_="abcfooabcbar"; | |
199 | $x=/abc/g; | |
200 | print $` eq "" ? "ok 52\n" : "not ok 52\n" if $x; | |
201 | $x=/abc/g; | |
202 | print $` eq "abcfoo" ? "ok 53\n" : "not ok 53\n" if $x; | |
203 | $x=/abc/g; | |
204 | print $x == 0 ? "ok 54\n" : "not ok 54\n"; | |
71be2cbc | 205 | pos = 0; |
a0d0e21e LW |
206 | $x=/ABC/gi; |
207 | print $` eq "" ? "ok 55\n" : "not ok 55\n" if $x; | |
208 | $x=/ABC/gi; | |
209 | print $` eq "abcfoo" ? "ok 56\n" : "not ok 56\n" if $x; | |
210 | $x=/ABC/gi; | |
211 | print $x == 0 ? "ok 57\n" : "not ok 57\n"; | |
71be2cbc | 212 | pos = 0; |
a0d0e21e LW |
213 | $x=/abc/g; |
214 | print $' eq "fooabcbar" ? "ok 58\n" : "not ok 58\n" if $x; | |
215 | $x=/abc/g; | |
216 | print $' eq "bar" ? "ok 59\n" : "not ok 59\n" if $x; | |
217 | $_ .= ''; | |
218 | @x=/abc/g; | |
219 | print scalar @x == 2 ? "ok 60\n" : "not ok 60\n"; | |
71be2cbc | 220 | |
221 | $_ = "abdc"; | |
222 | pos $_ = 2; | |
c90c0ff4 | 223 | /\Gc/gc; |
71be2cbc | 224 | print "not " if (pos $_) != 2; |
225 | print "ok 61\n"; | |
c90c0ff4 | 226 | /\Gc/g; |
227 | print "not " if defined pos $_; | |
228 | print "ok 62\n"; | |
c277df42 IZ |
229 | |
230 | $out = 1; | |
231 | 'abc' =~ m'a(?{ $out = 2 })b'; | |
232 | print "not " if $out != 2; | |
233 | print "ok 63\n"; | |
234 | ||
235 | $out = 1; | |
236 | 'abc' =~ m'a(?{ $out = 3 })c'; | |
237 | print "not " if $out != 1; | |
459f542a | 238 | print "ok 64\n"; |
c277df42 IZ |
239 | |
240 | $_ = 'foobar1 bar2 foobar3 barfoobar5 foobar6'; | |
241 | @out = /(?<!foo)bar./g; | |
242 | print "not " if "@out" ne 'bar2 barf'; | |
243 | print "ok 65\n"; | |
244 | ||
8d37f932 DD |
245 | # Tests which depend on REG_INFTY |
246 | $reg_infty = defined $Config{reg_infty} ? $Config{reg_infty} : 32767; | |
247 | $reg_infty_m = $reg_infty - 1; $reg_infty_p = $reg_infty + 1; | |
248 | ||
249 | # As well as failing if the pattern matches do unexpected things, the | |
250 | # next three tests will fail if you should have picked up a lower-than- | |
251 | # default value for $reg_infty from Config.pm, but have not. | |
252 | ||
253 | undef $@; | |
254 | print "not " if eval q(('aaa' =~ /(a{1,$reg_infty_m})/)[0] ne 'aaa') || $@; | |
255 | print "ok 66\n"; | |
256 | ||
257 | undef $@; | |
258 | print "not " if eval q(('a' x $reg_infty_m) !~ /a{$reg_infty_m}/) || $@; | |
259 | print "ok 67\n"; | |
260 | ||
261 | undef $@; | |
262 | print "not " if eval q(('a' x ($reg_infty_m - 1)) =~ /a{$reg_infty_m}/) || $@; | |
263 | print "ok 68\n"; | |
264 | ||
265 | undef $@; | |
266 | eval "'aaa' =~ /a{1,$reg_infty}/"; | |
9baa0206 | 267 | print "not " if $@ !~ m%^\QQuantifier in {,} bigger than%; |
8d37f932 DD |
268 | print "ok 69\n"; |
269 | ||
270 | eval "'aaa' =~ /a{1,$reg_infty_p}/"; | |
271 | print "not " | |
9baa0206 | 272 | if $@ !~ m%^\QQuantifier in {,} bigger than%; |
8d37f932 DD |
273 | print "ok 70\n"; |
274 | undef $@; | |
275 | ||
276 | # Poke a couple more parse failures | |
277 | ||
278 | $context = 'x' x 256; | |
279 | eval qq("${context}y" =~ /(?<=$context)y/); | |
9baa0206 | 280 | print "not " if $@ !~ m%^\QLookbehind longer than 255 not%; |
8d37f932 DD |
281 | print "ok 71\n"; |
282 | ||
b8c5462f | 283 | # removed test |
8d37f932 DD |
284 | print "ok 72\n"; |
285 | ||
c277df42 | 286 | # Long Monsters |
8d37f932 | 287 | $test = 73; |
c277df42 IZ |
288 | for $l (125, 140, 250, 270, 300000, 30) { # Ordered to free memory |
289 | $a = 'a' x $l; | |
290 | print "# length=$l\nnot " unless "ba$a=" =~ /a$a=/; | |
291 | print "ok $test\n"; | |
292 | $test++; | |
73d6d589 | 293 | |
c277df42 IZ |
294 | print "not " if "b$a=" =~ /a$a=/; |
295 | print "ok $test\n"; | |
296 | $test++; | |
297 | } | |
298 | ||
299 | # 20000 nodes, each taking 3 words per string, and 1 per branch | |
300 | $long_constant_len = join '|', 12120 .. 32645; | |
301 | $long_var_len = join '|', 8120 .. 28645; | |
302 | %ans = ( 'ax13876y25677lbc' => 1, | |
303 | 'ax13876y25677mcb' => 0, # not b. | |
304 | 'ax13876y35677nbc' => 0, # Num too big | |
305 | 'ax13876y25677y21378obc' => 1, | |
306 | 'ax13876y25677y21378zbc' => 0, # Not followed by [k-o] | |
307 | 'ax13876y25677y21378y21378kbc' => 1, | |
308 | 'ax13876y25677y21378y21378kcb' => 0, # Not b. | |
309 | 'ax13876y25677y21378y21378y21378kbc' => 0, # 5 runs | |
310 | ); | |
311 | ||
312 | for ( keys %ans ) { | |
73d6d589 | 313 | print "# const-len `$_' not => $ans{$_}\nnot " |
c277df42 IZ |
314 | if $ans{$_} xor /a(?=([yx]($long_constant_len)){2,4}[k-o]).*b./o; |
315 | print "ok $test\n"; | |
316 | $test++; | |
73d6d589 | 317 | print "# var-len `$_' not => $ans{$_}\nnot " |
c277df42 IZ |
318 | if $ans{$_} xor /a(?=([yx]($long_var_len)){2,4}[k-o]).*b./o; |
319 | print "ok $test\n"; | |
320 | $test++; | |
321 | } | |
322 | ||
323 | $_ = " a (bla()) and x(y b((l)u((e))) and b(l(e)e)e"; | |
324 | $expect = "(bla()) ((l)u((e))) (l(e)e)"; | |
325 | ||
73d6d589 | 326 | sub matchit { |
cc6b7395 | 327 | m/ |
c277df42 | 328 | ( |
73d6d589 | 329 | \( |
c277df42 IZ |
330 | (?{ $c = 1 }) # Initialize |
331 | (?: | |
332 | (?(?{ $c == 0 }) # PREVIOUS iteration was OK, stop the loop | |
333 | (?! | |
334 | ) # Fail: will unwind one iteration back | |
73d6d589 | 335 | ) |
c277df42 IZ |
336 | (?: |
337 | [^()]+ # Match a big chunk | |
338 | (?= | |
339 | [()] | |
340 | ) # Do not try to match subchunks | |
341 | | | |
73d6d589 | 342 | \( |
c277df42 IZ |
343 | (?{ ++$c }) |
344 | | | |
73d6d589 | 345 | \) |
c277df42 IZ |
346 | (?{ --$c }) |
347 | ) | |
348 | )+ # This may not match with different subblocks | |
349 | ) | |
350 | (?(?{ $c != 0 }) | |
351 | (?! | |
352 | ) # Fail | |
353 | ) # Otherwise the chunk 1 may succeed with $c>0 | |
cc6b7395 | 354 | /xg; |
c277df42 IZ |
355 | } |
356 | ||
0f5d15d6 | 357 | @ans = (); |
c277df42 IZ |
358 | push @ans, $res while $res = matchit; |
359 | ||
360 | print "# ans='@ans'\n# expect='$expect'\nnot " if "@ans" ne "1 1 1"; | |
361 | print "ok $test\n"; | |
362 | $test++; | |
363 | ||
364 | @ans = matchit; | |
365 | ||
366 | print "# ans='@ans'\n# expect='$expect'\nnot " if "@ans" ne $expect; | |
367 | print "ok $test\n"; | |
368 | $test++; | |
369 | ||
96776eda GS |
370 | print "not " unless "abc" =~ /^(??{"a"})b/; |
371 | print "ok $test\n"; | |
372 | $test++; | |
373 | ||
0f5d15d6 | 374 | my $matched; |
14455d6c | 375 | $matched = qr/\((?:(?>[^()]+)|(??{$matched}))*\)/; |
0f5d15d6 IZ |
376 | |
377 | @ans = @ans1 = (); | |
378 | push(@ans, $res), push(@ans1, $&) while $res = m/$matched/g; | |
379 | ||
380 | print "# ans='@ans'\n# expect='$expect'\nnot " if "@ans" ne "1 1 1"; | |
381 | print "ok $test\n"; | |
382 | $test++; | |
383 | ||
384 | print "# ans1='@ans1'\n# expect='$expect'\nnot " if "@ans1" ne $expect; | |
385 | print "ok $test\n"; | |
386 | $test++; | |
387 | ||
388 | @ans = m/$matched/g; | |
389 | ||
390 | print "# ans='@ans'\n# expect='$expect'\nnot " if "@ans" ne $expect; | |
391 | print "ok $test\n"; | |
392 | $test++; | |
393 | ||
c277df42 IZ |
394 | @ans = ('a/b' =~ m%(.*/)?(.*)%); # Stack may be bad |
395 | print "not " if "@ans" ne 'a/ b'; | |
396 | print "ok $test\n"; | |
397 | $test++; | |
398 | ||
cc6b7395 | 399 | $code = '{$blah = 45}'; |
c277df42 | 400 | $blah = 12; |
2cd61cdb IZ |
401 | eval { /(?$code)/ }; |
402 | print "not " unless $@ and $@ =~ /not allowed at runtime/ and $blah == 12; | |
e4d48cc9 GS |
403 | print "ok $test\n"; |
404 | $test++; | |
405 | ||
2cd61cdb IZ |
406 | for $code ('{$blah = 45}','=xx') { |
407 | $blah = 12; | |
408 | $res = eval { "xx" =~ /(?$code)/o }; | |
409 | if ($code eq '=xx') { | |
410 | print "#'$@','$res','$blah'\nnot " unless not $@ and $res; | |
411 | } else { | |
73d6d589 | 412 | print "#'$@','$res','$blah'\nnot " unless $@ and $@ =~ /not allowed at runtime/ and $blah == 12; |
2cd61cdb IZ |
413 | } |
414 | print "ok $test\n"; | |
415 | $test++; | |
416 | } | |
417 | ||
e4d48cc9 GS |
418 | $code = '{$blah = 45}'; |
419 | $blah = 12; | |
420 | eval "/(?$code)/"; | |
cc6b7395 IZ |
421 | print "not " if $blah != 45; |
422 | print "ok $test\n"; | |
423 | $test++; | |
424 | ||
425 | $blah = 12; | |
426 | /(?{$blah = 45})/; | |
c277df42 IZ |
427 | print "not " if $blah != 45; |
428 | print "ok $test\n"; | |
429 | $test++; | |
430 | ||
74d6a13a MB |
431 | $x = 'banana'; |
432 | $x =~ /.a/g; | |
433 | print "not " unless pos($x) == 2; | |
434 | print "ok $test\n"; | |
435 | $test++; | |
436 | ||
437 | $x =~ /.z/gc; | |
438 | print "not " unless pos($x) == 2; | |
439 | print "ok $test\n"; | |
440 | $test++; | |
441 | ||
442 | sub f { | |
443 | my $p = $_[0]; | |
444 | return $p; | |
445 | } | |
446 | ||
447 | $x =~ /.a/g; | |
448 | print "not " unless f(pos($x)) == 4; | |
449 | print "ok $test\n"; | |
450 | $test++; | |
4599a1de | 451 | |
ce862d02 IZ |
452 | $x = $^R = 67; |
453 | 'foot' =~ /foo(?{$x = 12; 75})[t]/; | |
454 | print "not " unless $^R eq '75'; | |
455 | print "ok $test\n"; | |
456 | $test++; | |
457 | ||
458 | $x = $^R = 67; | |
459 | 'foot' =~ /foo(?{$x = 12; 75})[xy]/; | |
460 | print "not " unless $^R eq '67' and $x eq '12'; | |
461 | print "ok $test\n"; | |
462 | $test++; | |
463 | ||
464 | $x = $^R = 67; | |
465 | 'foot' =~ /foo(?{ $^R + 12 })((?{ $x = 12; $^R + 17 })[xy])?/; | |
466 | print "not " unless $^R eq '79' and $x eq '12'; | |
467 | print "ok $test\n"; | |
468 | $test++; | |
469 | ||
8782bef2 GB |
470 | print "not " unless qr/\b\v$/i eq '(?i-xsm:\bv$)'; |
471 | print "ok $test\n"; | |
472 | $test++; | |
473 | ||
474 | print "not " unless qr/\b\v$/s eq '(?s-xim:\bv$)'; | |
475 | print "ok $test\n"; | |
476 | $test++; | |
477 | ||
478 | print "not " unless qr/\b\v$/m eq '(?m-xis:\bv$)'; | |
479 | print "ok $test\n"; | |
480 | $test++; | |
481 | ||
482 | print "not " unless qr/\b\v$/x eq '(?x-ism:\bv$)'; | |
483 | print "ok $test\n"; | |
484 | $test++; | |
485 | ||
486 | print "not " unless qr/\b\v$/xism eq '(?msix:\bv$)'; | |
487 | print "ok $test\n"; | |
488 | $test++; | |
489 | ||
490 | print "not " unless qr/\b\v$/ eq '(?-xism:\bv$)'; | |
97197631 IZ |
491 | print "ok $test\n"; |
492 | $test++; | |
493 | ||
7e5428c5 IZ |
494 | $_ = 'xabcx'; |
495 | foreach $ans ('', 'c') { | |
496 | /(?<=(?=a)..)((?=c)|.)/g; | |
02db2b7b | 497 | print "# \$1 ='$1'\n# \$ans='$ans'\nnot " unless $1 eq $ans; |
7e5428c5 IZ |
498 | print "ok $test\n"; |
499 | $test++; | |
500 | } | |
501 | ||
502 | $_ = 'a'; | |
503 | foreach $ans ('', 'a', '') { | |
504 | /^|a|$/g; | |
02db2b7b | 505 | print "# \$& ='$&'\n# \$ans='$ans'\nnot " unless $& eq $ans; |
7e5428c5 IZ |
506 | print "ok $test\n"; |
507 | $test++; | |
508 | } | |
509 | ||
09f25ae4 | 510 | sub prefixify { |
73d6d589 NIS |
511 | my($v,$a,$b,$res) = @_; |
512 | $v =~ s/\Q$a\E/$b/; | |
513 | print "not " unless $res eq $v; | |
09f25ae4 IZ |
514 | print "ok $test\n"; |
515 | $test++; | |
516 | } | |
517 | prefixify('/a/b/lib/arch', "/a/b/lib", 'X/lib', 'X/lib/arch'); | |
518 | prefixify('/a/b/man/arch', "/a/b/man", 'X/man', 'X/man/arch'); | |
519 | ||
520 | $_ = 'var="foo"'; | |
521 | /(\")/; | |
522 | print "not " unless $1 and /$1/; | |
523 | print "ok $test\n"; | |
524 | $test++; | |
525 | ||
73d6d589 | 526 | $a=qr/(?{++$b})/; |
2cd61cdb | 527 | $b = 7; |
73d6d589 NIS |
528 | /$a$a/; |
529 | print "not " unless $b eq '9'; | |
2cd61cdb IZ |
530 | print "ok $test\n"; |
531 | $test++; | |
532 | ||
73d6d589 NIS |
533 | $c="$a"; |
534 | /$a$a/; | |
535 | print "not " unless $b eq '11'; | |
2cd61cdb IZ |
536 | print "ok $test\n"; |
537 | $test++; | |
538 | ||
539 | { | |
73d6d589 NIS |
540 | use re "eval"; |
541 | /$a$c$a/; | |
542 | print "not " unless $b eq '14'; | |
2cd61cdb IZ |
543 | print "ok $test\n"; |
544 | $test++; | |
545 | ||
160cb429 JH |
546 | local $lex_a = 2; |
547 | my $lex_a = 43; | |
548 | my $lex_b = 17; | |
549 | my $lex_c = 27; | |
550 | my $lex_res = ($lex_b =~ qr/$lex_b(?{ $lex_c = $lex_a++ })/); | |
551 | print "not " unless $lex_res eq '1'; | |
552 | print "ok $test\n"; | |
553 | $test++; | |
554 | print "not " unless $lex_a eq '44'; | |
555 | print "ok $test\n"; | |
556 | $test++; | |
557 | print "not " unless $lex_c eq '43'; | |
558 | print "ok $test\n"; | |
559 | $test++; | |
560 | ||
561 | ||
73d6d589 | 562 | no re "eval"; |
2cd61cdb | 563 | $match = eval { /$a$c$a/ }; |
73d6d589 | 564 | print "not " |
2cd61cdb IZ |
565 | unless $b eq '14' and $@ =~ /Eval-group not allowed/ and not $match; |
566 | print "ok $test\n"; | |
567 | $test++; | |
568 | } | |
cbce877f IZ |
569 | |
570 | { | |
160cb429 JH |
571 | local $lex_a = 2; |
572 | my $lex_a = 43; | |
573 | my $lex_b = 17; | |
574 | my $lex_c = 27; | |
575 | my $lex_res = ($lex_b =~ qr/17(?{ $lex_c = $lex_a++ })/); | |
576 | print "not " unless $lex_res eq '1'; | |
577 | print "ok $test\n"; | |
578 | $test++; | |
579 | print "not " unless $lex_a eq '44'; | |
580 | print "ok $test\n"; | |
581 | $test++; | |
582 | print "not " unless $lex_c eq '43'; | |
583 | print "ok $test\n"; | |
584 | $test++; | |
585 | } | |
586 | ||
587 | { | |
cbce877f IZ |
588 | package aa; |
589 | $c = 2; | |
590 | $::c = 3; | |
591 | '' =~ /(?{ $c = 4 })/; | |
592 | print "not " unless $c == 4; | |
593 | } | |
594 | print "ok $test\n"; | |
595 | $test++; | |
596 | print "not " unless $c == 3; | |
597 | print "ok $test\n"; | |
73d6d589 NIS |
598 | $test++; |
599 | ||
4599a1de JH |
600 | sub must_warn_pat { |
601 | my $warn_pat = shift; | |
602 | return sub { print "not " unless $_[0] =~ /$warn_pat/ } | |
603 | } | |
604 | ||
605 | sub must_warn { | |
606 | my ($warn_pat, $code) = @_; | |
9f1b1f2d GS |
607 | local %SIG; |
608 | eval 'BEGIN { use warnings; $SIG{__WARN__} = $warn_pat };' . $code; | |
4599a1de JH |
609 | print "ok $test\n"; |
610 | $test++; | |
611 | } | |
612 | ||
613 | ||
614 | sub make_must_warn { | |
615 | my $warn_pat = shift; | |
616 | return sub { must_warn(must_warn_pat($warn_pat)) } | |
617 | } | |
618 | ||
619 | my $for_future = make_must_warn('reserved for future extensions'); | |
620 | ||
621 | &$for_future('q(a:[b]:) =~ /[x[:foo:]]/'); | |
9baa0206 HS |
622 | |
623 | #&$for_future('q(a=[b]=) =~ /[x[=foo=]]/'); | |
624 | print "ok $test\n"; $test++; # now a fatal croak | |
625 | ||
626 | #&$for_future('q(a.[b].) =~ /[x[.foo.]]/'); | |
627 | print "ok $test\n"; $test++; # now a fatal croak | |
f7e33566 GS |
628 | |
629 | # test if failure of patterns returns empty list | |
630 | $_ = 'aaa'; | |
631 | @_ = /bbb/; | |
632 | print "not " if @_; | |
633 | print "ok $test\n"; | |
634 | $test++; | |
635 | ||
636 | @_ = /bbb/g; | |
637 | print "not " if @_; | |
638 | print "ok $test\n"; | |
639 | $test++; | |
640 | ||
641 | @_ = /(bbb)/; | |
642 | print "not " if @_; | |
643 | print "ok $test\n"; | |
644 | $test++; | |
645 | ||
646 | @_ = /(bbb)/g; | |
647 | print "not " if @_; | |
648 | print "ok $test\n"; | |
649 | $test++; | |
650 | ||
6cef1e77 IZ |
651 | /a(?=.$)/; |
652 | print "not " if $#+ != 0 or $#- != 0; | |
653 | print "ok $test\n"; | |
654 | $test++; | |
655 | ||
656 | print "not " if $+[0] != 2 or $-[0] != 1; | |
657 | print "ok $test\n"; | |
658 | $test++; | |
659 | ||
73d6d589 | 660 | print "not " |
6cef1e77 IZ |
661 | if defined $+[1] or defined $-[1] or defined $+[2] or defined $-[2]; |
662 | print "ok $test\n"; | |
663 | $test++; | |
664 | ||
665 | /a(a)(a)/; | |
666 | print "not " if $#+ != 2 or $#- != 2; | |
667 | print "ok $test\n"; | |
668 | $test++; | |
669 | ||
670 | print "not " if $+[0] != 3 or $-[0] != 0; | |
671 | print "ok $test\n"; | |
672 | $test++; | |
673 | ||
674 | print "not " if $+[1] != 2 or $-[1] != 1; | |
675 | print "ok $test\n"; | |
676 | $test++; | |
677 | ||
678 | print "not " if $+[2] != 3 or $-[2] != 2; | |
679 | print "ok $test\n"; | |
680 | $test++; | |
681 | ||
73d6d589 | 682 | print "not " |
6cef1e77 IZ |
683 | if defined $+[3] or defined $-[3] or defined $+[4] or defined $-[4]; |
684 | print "ok $test\n"; | |
685 | $test++; | |
686 | ||
687 | /.(a)(b)?(a)/; | |
688 | print "not " if $#+ != 3 or $#- != 3; | |
689 | print "ok $test\n"; | |
690 | $test++; | |
691 | ||
692 | print "not " if $+[0] != 3 or $-[0] != 0; | |
693 | print "ok $test\n"; | |
694 | $test++; | |
695 | ||
696 | print "not " if $+[1] != 2 or $-[1] != 1; | |
697 | print "ok $test\n"; | |
698 | $test++; | |
699 | ||
700 | print "not " if $+[3] != 3 or $-[3] != 2; | |
701 | print "ok $test\n"; | |
702 | $test++; | |
703 | ||
73d6d589 | 704 | print "not " |
6cef1e77 IZ |
705 | if defined $+[2] or defined $-[2] or defined $+[4] or defined $-[4]; |
706 | print "ok $test\n"; | |
707 | $test++; | |
708 | ||
709 | /.(a)/; | |
710 | print "not " if $#+ != 1 or $#- != 1; | |
711 | print "ok $test\n"; | |
712 | $test++; | |
713 | ||
714 | print "not " if $+[0] != 2 or $-[0] != 0; | |
715 | print "ok $test\n"; | |
716 | $test++; | |
717 | ||
718 | print "not " if $+[1] != 2 or $-[1] != 1; | |
719 | print "ok $test\n"; | |
720 | $test++; | |
721 | ||
73d6d589 | 722 | print "not " |
6cef1e77 IZ |
723 | if defined $+[2] or defined $-[2] or defined $+[3] or defined $-[3]; |
724 | print "ok $test\n"; | |
725 | $test++; | |
726 | ||
03a27ae7 | 727 | eval { $+[0] = 13; }; |
73d6d589 | 728 | print "not " |
03a27ae7 MG |
729 | if $@ !~ /^Modification of a read-only value attempted/; |
730 | print "ok $test\n"; | |
731 | $test++; | |
732 | ||
733 | eval { $-[0] = 13; }; | |
73d6d589 | 734 | print "not " |
03a27ae7 MG |
735 | if $@ !~ /^Modification of a read-only value attempted/; |
736 | print "ok $test\n"; | |
737 | $test++; | |
738 | ||
739 | eval { @+ = (7, 6, 5); }; | |
73d6d589 | 740 | print "not " |
03a27ae7 MG |
741 | if $@ !~ /^Modification of a read-only value attempted/; |
742 | print "ok $test\n"; | |
743 | $test++; | |
744 | ||
745 | eval { @- = qw(foo bar); }; | |
73d6d589 | 746 | print "not " |
03a27ae7 MG |
747 | if $@ !~ /^Modification of a read-only value attempted/; |
748 | print "ok $test\n"; | |
749 | $test++; | |
750 | ||
8f580fb8 IZ |
751 | /.(a)(ba*)?/; |
752 | print "#$#-..$#+\nnot " if $#+ != 2 or $#- != 1; | |
753 | print "ok $test\n"; | |
754 | $test++; | |
755 | ||
ad94a511 IZ |
756 | $_ = 'aaa'; |
757 | pos = 1; | |
758 | @a = /\Ga/g; | |
759 | print "not " unless "@a" eq "a a"; | |
760 | print "ok $test\n"; | |
761 | $test++; | |
762 | ||
22e551b9 IZ |
763 | $str = 'abcde'; |
764 | pos $str = 2; | |
765 | ||
766 | print "not " if $str =~ /^\G/; | |
767 | print "ok $test\n"; | |
768 | $test++; | |
769 | ||
770 | print "not " if $str =~ /^.\G/; | |
771 | print "ok $test\n"; | |
772 | $test++; | |
773 | ||
774 | print "not " unless $str =~ /^..\G/; | |
775 | print "ok $test\n"; | |
776 | $test++; | |
777 | ||
778 | print "not " if $str =~ /^...\G/; | |
779 | print "ok $test\n"; | |
780 | $test++; | |
781 | ||
782 | print "not " unless $str =~ /.\G./ and $& eq 'bc'; | |
783 | print "ok $test\n"; | |
784 | $test++; | |
785 | ||
786 | print "not " unless $str =~ /\G../ and $& eq 'cd'; | |
787 | print "ok $test\n"; | |
788 | $test++; | |
789 | ||
9661b544 IZ |
790 | undef $foo; undef $bar; |
791 | print "#'$str','$foo','$bar'\nnot " | |
73d6d589 | 792 | unless $str =~ /b(?{$foo = $_; $bar = pos})c/ |
9661b544 IZ |
793 | and $foo eq 'abcde' and $bar eq 2; |
794 | print "ok $test\n"; | |
795 | $test++; | |
796 | ||
797 | undef $foo; undef $bar; | |
798 | pos $str = undef; | |
799 | print "#'$str','$foo','$bar'\nnot " | |
73d6d589 | 800 | unless $str =~ /b(?{$foo = $_; $bar = pos})c/g |
9661b544 IZ |
801 | and $foo eq 'abcde' and $bar eq 2 and pos $str eq 3; |
802 | print "ok $test\n"; | |
803 | $test++; | |
804 | ||
805 | $_ = $str; | |
806 | ||
807 | undef $foo; undef $bar; | |
808 | print "#'$str','$foo','$bar'\nnot " | |
73d6d589 | 809 | unless /b(?{$foo = $_; $bar = pos})c/ |
9661b544 IZ |
810 | and $foo eq 'abcde' and $bar eq 2; |
811 | print "ok $test\n"; | |
812 | $test++; | |
813 | ||
814 | undef $foo; undef $bar; | |
815 | print "#'$str','$foo','$bar'\nnot " | |
73d6d589 | 816 | unless /b(?{$foo = $_; $bar = pos})c/g |
9661b544 IZ |
817 | and $foo eq 'abcde' and $bar eq 2 and pos eq 3; |
818 | print "ok $test\n"; | |
819 | $test++; | |
820 | ||
821 | undef $foo; undef $bar; | |
822 | pos = undef; | |
823 | 1 while /b(?{$foo = $_; $bar = pos})c/g; | |
824 | print "#'$str','$foo','$bar'\nnot " | |
825 | unless $foo eq 'abcde' and $bar eq 2 and not defined pos; | |
826 | print "ok $test\n"; | |
827 | $test++; | |
828 | ||
829 | undef $foo; undef $bar; | |
830 | $_ = 'abcde|abcde'; | |
831 | print "#'$str','$foo','$bar','$_'\nnot " | |
73d6d589 | 832 | unless s/b(?{$foo = $_; $bar = pos})c/x/g and $foo eq 'abcde|abcde' |
9661b544 IZ |
833 | and $bar eq 8 and $_ eq 'axde|axde'; |
834 | print "ok $test\n"; | |
835 | $test++; | |
836 | ||
5c5e4c24 IZ |
837 | @res = (); |
838 | # List context: | |
839 | $_ = 'abcde|abcde'; | |
840 | @dummy = /([ace]).(?{push @res, $1,$2})([ce])(?{push @res, $1,$2})/g; | |
841 | @res = map {defined $_ ? "'$_'" : 'undef'} @res; | |
842 | $res = "@res"; | |
843 | print "#'@res' '$_'\nnot " | |
844 | unless "@res" eq "'a' undef 'a' 'c' 'e' undef 'a' undef 'a' 'c'"; | |
845 | print "ok $test\n"; | |
846 | $test++; | |
847 | ||
848 | @res = (); | |
849 | @dummy = /([ace]).(?{push @res, $`,$&,$'})([ce])(?{push @res, $`,$&,$'})/g; | |
850 | @res = map {defined $_ ? "'$_'" : 'undef'} @res; | |
851 | $res = "@res"; | |
852 | print "#'@res' '$_'\nnot " | |
853 | unless "@res" eq | |
854 | "'' 'ab' 'cde|abcde' " . | |
855 | "'' 'abc' 'de|abcde' " . | |
856 | "'abcd' 'e|' 'abcde' " . | |
857 | "'abcde|' 'ab' 'cde' " . | |
858 | "'abcde|' 'abc' 'de'" ; | |
859 | print "ok $test\n"; | |
860 | $test++; | |
861 | ||
b7a35066 IZ |
862 | #Some more \G anchor checks |
863 | $foo='aabbccddeeffgg'; | |
864 | ||
865 | pos($foo)=1; | |
866 | ||
867 | $foo=~/.\G(..)/g; | |
868 | print "not " unless($1 eq 'ab'); | |
869 | print "ok $test\n"; | |
870 | $test++; | |
871 | ||
872 | pos($foo) += 1; | |
873 | $foo=~/.\G(..)/g; | |
874 | print "not " unless($1 eq 'cc'); | |
875 | print "ok $test\n"; | |
876 | $test++; | |
877 | ||
878 | pos($foo) += 1; | |
879 | $foo=~/.\G(..)/g; | |
880 | print "not " unless($1 eq 'de'); | |
881 | print "ok $test\n"; | |
882 | $test++; | |
883 | ||
0ef3e39e HS |
884 | print "not " unless $foo =~ /\Gef/g; |
885 | print "ok $test\n"; | |
886 | $test++; | |
887 | ||
b7a35066 IZ |
888 | undef pos $foo; |
889 | ||
890 | $foo=~/\G(..)/g; | |
891 | print "not " unless($1 eq 'aa'); | |
892 | print "ok $test\n"; | |
893 | $test++; | |
894 | ||
895 | $foo=~/\G(..)/g; | |
896 | print "not " unless($1 eq 'bb'); | |
897 | print "ok $test\n"; | |
898 | $test++; | |
899 | ||
900 | pos($foo)=5; | |
901 | $foo=~/\G(..)/g; | |
902 | print "not " unless($1 eq 'cd'); | |
903 | print "ok $test\n"; | |
904 | $test++; | |
905 | ||
73d6d589 | 906 | $_='123x123'; |
e60df1fa IZ |
907 | @res = /(\d*|x)/g; |
908 | print "not " unless('123||x|123|' eq join '|', @res); | |
909 | print "ok $test\n"; | |
910 | $test++; | |
911 | ||
9d080a66 GS |
912 | # see if matching against temporaries (created via pp_helem()) is safe |
913 | { foo => "ok $test\n".$^X }->{foo} =~ /^(.*)\n/g; | |
914 | print "$1\n"; | |
915 | $test++; | |
916 | ||
cf93c79d IZ |
917 | # See if $i work inside (?{}) in the presense of saved substrings and |
918 | # changing $_ | |
919 | @a = qw(foo bar); | |
920 | @b = (); | |
921 | s/(\w)(?{push @b, $1})/,$1,/g for @a; | |
922 | ||
923 | print "# \@b='@b', expect 'f o o b a r'\nnot " unless("@b" eq "f o o b a r"); | |
924 | print "ok $test\n"; | |
925 | $test++; | |
926 | ||
927 | print "not " unless("@a" eq ",f,,o,,o, ,b,,a,,r,"); | |
928 | print "ok $test\n"; | |
929 | $test++; | |
930 | ||
2c914db6 | 931 | $brackets = qr{ |
14455d6c | 932 | { (?> [^{}]+ | (??{ $brackets }) )* } |
2c914db6 IZ |
933 | }x; |
934 | ||
935 | "{{}" =~ $brackets; | |
936 | print "ok $test\n"; # Did we survive? | |
937 | $test++; | |
938 | ||
939 | "something { long { and } hairy" =~ $brackets; | |
940 | print "ok $test\n"; # Did we survive? | |
941 | $test++; | |
942 | ||
14455d6c | 943 | "something { long { and } hairy" =~ m/((??{ $brackets }))/; |
2c914db6 IZ |
944 | print "not " unless $1 eq "{ and }"; |
945 | print "ok $test\n"; | |
946 | $test++; | |
947 | ||
30944b6d IZ |
948 | $_ = "a-a\nxbb"; |
949 | pos=1; | |
950 | m/^-.*bb/mg and print "not "; | |
951 | print "ok $test\n"; | |
952 | $test++; | |
30382c73 IZ |
953 | |
954 | $text = "aaXbXcc"; | |
955 | pos($text)=0; | |
956 | $text =~ /\GXb*X/g and print 'not '; | |
957 | print "ok $test\n"; | |
958 | $test++; | |
3cf5c195 IZ |
959 | |
960 | $text = "xA\n" x 500; | |
961 | $text =~ /^\s*A/m and print 'not '; | |
962 | print "ok $test\n"; | |
963 | $test++; | |
d506a20d IZ |
964 | |
965 | $text = "abc dbf"; | |
966 | @res = ($text =~ /.*?(b).*?\b/g); | |
967 | "@res" eq 'b b' or print 'not '; | |
968 | print "ok $test\n"; | |
969 | $test++; | |
970 | ||
9442cb0e | 971 | @a = map chr,0..255; |
aeaf5620 GS |
972 | |
973 | @b = grep(/\S/,@a); | |
974 | @c = grep(/[^\s]/,@a); | |
975 | print "not " if "@b" ne "@c"; | |
9442cb0e GS |
976 | print "ok $test\n"; |
977 | $test++; | |
978 | ||
aeaf5620 GS |
979 | @b = grep(/\S/,@a); |
980 | @c = grep(/[\S]/,@a); | |
981 | print "not " if "@b" ne "@c"; | |
9442cb0e GS |
982 | print "ok $test\n"; |
983 | $test++; | |
984 | ||
aeaf5620 GS |
985 | @b = grep(/\s/,@a); |
986 | @c = grep(/[^\S]/,@a); | |
987 | print "not " if "@b" ne "@c"; | |
9442cb0e GS |
988 | print "ok $test\n"; |
989 | $test++; | |
990 | ||
aeaf5620 GS |
991 | @b = grep(/\s/,@a); |
992 | @c = grep(/[\s]/,@a); | |
993 | print "not " if "@b" ne "@c"; | |
9442cb0e GS |
994 | print "ok $test\n"; |
995 | $test++; | |
996 | ||
aeaf5620 GS |
997 | @b = grep(/\D/,@a); |
998 | @c = grep(/[^\d]/,@a); | |
999 | print "not " if "@b" ne "@c"; | |
9442cb0e GS |
1000 | print "ok $test\n"; |
1001 | $test++; | |
1002 | ||
aeaf5620 GS |
1003 | @b = grep(/\D/,@a); |
1004 | @c = grep(/[\D]/,@a); | |
1005 | print "not " if "@b" ne "@c"; | |
9442cb0e GS |
1006 | print "ok $test\n"; |
1007 | $test++; | |
1008 | ||
aeaf5620 GS |
1009 | @b = grep(/\d/,@a); |
1010 | @c = grep(/[^\D]/,@a); | |
1011 | print "not " if "@b" ne "@c"; | |
9442cb0e GS |
1012 | print "ok $test\n"; |
1013 | $test++; | |
1014 | ||
aeaf5620 GS |
1015 | @b = grep(/\d/,@a); |
1016 | @c = grep(/[\d]/,@a); | |
1017 | print "not " if "@b" ne "@c"; | |
9442cb0e GS |
1018 | print "ok $test\n"; |
1019 | $test++; | |
1020 | ||
aeaf5620 GS |
1021 | @b = grep(/\W/,@a); |
1022 | @c = grep(/[^\w]/,@a); | |
1023 | print "not " if "@b" ne "@c"; | |
9442cb0e GS |
1024 | print "ok $test\n"; |
1025 | $test++; | |
1026 | ||
aeaf5620 GS |
1027 | @b = grep(/\W/,@a); |
1028 | @c = grep(/[\W]/,@a); | |
1029 | print "not " if "@b" ne "@c"; | |
9442cb0e GS |
1030 | print "ok $test\n"; |
1031 | $test++; | |
1032 | ||
aeaf5620 GS |
1033 | @b = grep(/\w/,@a); |
1034 | @c = grep(/[^\W]/,@a); | |
1035 | print "not " if "@b" ne "@c"; | |
9442cb0e GS |
1036 | print "ok $test\n"; |
1037 | $test++; | |
1038 | ||
aeaf5620 GS |
1039 | @b = grep(/\w/,@a); |
1040 | @c = grep(/[\w]/,@a); | |
1041 | print "not " if "@b" ne "@c"; | |
9442cb0e GS |
1042 | print "ok $test\n"; |
1043 | $test++; | |
1aeab75a GS |
1044 | |
1045 | # see if backtracking optimization works correctly | |
1046 | "\n\n" =~ /\n $ \n/x or print "not "; | |
1047 | print "ok $test\n"; | |
1048 | $test++; | |
1049 | ||
1050 | "\n\n" =~ /\n* $ \n/x or print "not "; | |
1051 | print "ok $test\n"; | |
1052 | $test++; | |
1053 | ||
1054 | "\n\n" =~ /\n+ $ \n/x or print "not "; | |
1055 | print "ok $test\n"; | |
1056 | $test++; | |
05b4157f GS |
1057 | |
1058 | [] =~ /^ARRAY/ or print "# [] \nnot "; | |
1059 | print "ok $test\n"; | |
1060 | $test++; | |
1061 | ||
1062 | eval << 'EOE'; | |
1063 | { | |
1064 | package S; | |
1065 | use overload '""' => sub { 'Object S' }; | |
1066 | sub new { bless [] } | |
1067 | } | |
1068 | $a = 'S'->new; | |
1069 | EOE | |
1070 | ||
1071 | $a and $a =~ /^Object\sS/ or print "# '$a' \nnot "; | |
1072 | print "ok $test\n"; | |
1073 | $test++; | |
815d35b9 MG |
1074 | |
1075 | # test result of match used as match (!) | |
1076 | 'a1b' =~ ('xyz' =~ /y/) and $` eq 'a' or print "not "; | |
1077 | print "ok $test\n"; | |
1078 | $test++; | |
1079 | ||
1080 | 'a1b' =~ ('xyz' =~ /t/) and $` eq 'a' or print "not "; | |
1081 | print "ok $test\n"; | |
1082 | $test++; | |
5e39e1e5 HS |
1083 | |
1084 | $w = 0; | |
1085 | { | |
1086 | local $SIG{__WARN__} = sub { $w = 1 }; | |
1087 | local $^W = 1; | |
1088 | $w = 1 if ("1\n" x 102) =~ /^\s*\n/m; | |
1089 | } | |
1090 | print $w ? "not " : "", "ok $test\n"; | |
1091 | $test++; | |
aaa51d5e JF |
1092 | |
1093 | my %space = ( spc => " ", | |
1094 | tab => "\t", | |
1095 | cr => "\r", | |
1096 | lf => "\n", | |
1097 | ff => "\f", | |
75369ccb JH |
1098 | # There's no \v but the vertical tabulator seems miraculously |
1099 | # be 11 both in ASCII and EBCDIC. | |
aaa51d5e JF |
1100 | vt => chr(11), |
1101 | false => "space" ); | |
1102 | ||
1103 | my @space0 = sort grep { $space{$_} =~ /\s/ } keys %space; | |
1104 | my @space1 = sort grep { $space{$_} =~ /[[:space:]]/ } keys %space; | |
1105 | my @space2 = sort grep { $space{$_} =~ /[[:blank:]]/ } keys %space; | |
1106 | ||
1107 | print "not " unless "@space0" eq "cr ff lf spc tab"; | |
3bec3564 | 1108 | print "ok $test # @space0\n"; |
aaa51d5e JF |
1109 | $test++; |
1110 | ||
1111 | print "not " unless "@space1" eq "cr ff lf spc tab vt"; | |
3bec3564 | 1112 | print "ok $test # @space1\n"; |
aaa51d5e JF |
1113 | $test++; |
1114 | ||
1115 | print "not " unless "@space2" eq "spc tab"; | |
3bec3564 | 1116 | print "ok $test # @space2\n"; |
aaa51d5e | 1117 | $test++; |
73d6d589 | 1118 | |
a1933d95 HS |
1119 | # bugid 20001021.005 - this caused a SEGV |
1120 | print "not " unless undef =~ /^([^\/]*)(.*)$/; | |
1121 | print "ok $test\n"; | |
1122 | $test++; | |
b91bb191 JH |
1123 | |
1124 | # bugid 20000731.001 | |
1125 | ||
1126 | print "not " unless "A \x{263a} B z C" =~ /A . B (??{ "z" }) C/; | |
1127 | print "ok $test\n"; | |
1128 | $test++; | |
1129 | ||
5ae032e5 JH |
1130 | my $ordA = ord('A'); |
1131 | ||
3baa4c62 JH |
1132 | $_ = "a\x{100}b"; |
1133 | if (/(.)(\C)(\C)(.)/) { | |
1134 | print "ok 232\n"; | |
1135 | if ($1 eq "a") { | |
1136 | print "ok 233\n"; | |
1137 | } else { | |
1138 | print "not ok 233\n"; | |
1139 | } | |
5ae032e5 JH |
1140 | if ($ordA == 65) { # ASCII (or equivalent), should be UTF-8 |
1141 | if ($2 eq "\xC4") { | |
1142 | print "ok 234\n"; | |
1143 | } else { | |
1144 | print "not ok 234\n"; | |
1145 | } | |
1146 | if ($3 eq "\x80") { | |
1147 | print "ok 235\n"; | |
1148 | } else { | |
1149 | print "not ok 235\n"; | |
1150 | } | |
1151 | } elsif ($ordA == 193) { # EBCDIC (or equivalent), should be UTF-EBCDIC | |
1152 | if ($2 eq "\x8C") { | |
1153 | print "ok 234\n"; | |
1154 | } else { | |
1155 | print "not ok 234\n"; | |
1156 | } | |
1157 | if ($3 eq "\x41") { | |
1158 | print "ok 235\n"; | |
1159 | } else { | |
1160 | print "not ok 235\n"; | |
1161 | } | |
3baa4c62 | 1162 | } else { |
5ae032e5 JH |
1163 | for (234..235) { |
1164 | print "not ok $_ # ord('A') == $ordA\n"; | |
1165 | } | |
3baa4c62 JH |
1166 | } |
1167 | if ($4 eq "b") { | |
1168 | print "ok 236\n"; | |
1169 | } else { | |
1170 | print "not ok 236\n"; | |
1171 | } | |
1172 | } else { | |
1173 | for (232..236) { | |
1174 | print "not ok $_\n"; | |
1175 | } | |
1176 | } | |
1177 | $_ = "\x{100}"; | |
1178 | if (/(\C)/g) { | |
1179 | print "ok 237\n"; | |
73d6d589 | 1180 | # currently \C are still tagged as UTF-8 |
5ae032e5 JH |
1181 | if ($ordA == 65) { |
1182 | if ($1 eq "\xC4") { | |
1183 | print "ok 238\n"; | |
1184 | } else { | |
1185 | print "not ok 238\n"; | |
1186 | } | |
1187 | } elsif ($ordA == 193) { | |
1188 | if ($1 eq "\x8C") { | |
1189 | print "ok 238\n"; | |
1190 | } else { | |
1191 | print "not ok 238\n"; | |
1192 | } | |
3baa4c62 | 1193 | } else { |
5ae032e5 | 1194 | print "not ok 238 # ord('A') == $ordA\n"; |
3baa4c62 JH |
1195 | } |
1196 | } else { | |
1197 | for (237..238) { | |
1198 | print "not ok $_\n"; | |
1199 | } | |
1200 | } | |
1201 | if (/(\C)/g) { | |
1202 | print "ok 239\n"; | |
73d6d589 | 1203 | # currently \C are still tagged as UTF-8 |
5ae032e5 JH |
1204 | if ($ordA == 65) { |
1205 | if ($1 eq "\x80") { | |
1206 | print "ok 240\n"; | |
1207 | } else { | |
1208 | print "not ok 240\n"; | |
1209 | } | |
1210 | } elsif ($ordA == 193) { | |
1211 | if ($1 eq "\x41") { | |
1212 | print "ok 240\n"; | |
1213 | } else { | |
1214 | print "not ok 240\n"; | |
1215 | } | |
3baa4c62 | 1216 | } else { |
5ae032e5 | 1217 | print "not ok 240 # ord('A') == $ordA\n"; |
3baa4c62 JH |
1218 | } |
1219 | } else { | |
1220 | for (239..240) { | |
1221 | print "not ok $_\n"; | |
1222 | } | |
1223 | } | |
b485d051 | 1224 | |
db615365 JP |
1225 | { |
1226 | # japhy -- added 03/03/2001 | |
1227 | () = (my $str = "abc") =~ /(...)/; | |
1228 | $str = "def"; | |
1229 | print "not " if $1 ne "abc"; | |
fd291da9 JH |
1230 | print "ok 241\n"; |
1231 | } | |
1232 | ||
1233 | # The 242 and 243 go with the 244 and 245. | |
1234 | # The trick is that in EBCDIC the explicit numeric range should match | |
1235 | # (as also in non-EBCDIC) but the explicit alphabetic range should not match. | |
1236 | ||
1237 | if ("\x8e" =~ /[\x89-\x91]/) { | |
1238 | print "ok 242\n"; | |
1239 | } else { | |
1240 | print "not ok 242\n"; | |
1241 | } | |
1242 | ||
1243 | if ("\xce" =~ /[\xc9-\xd1]/) { | |
db615365 | 1244 | print "ok 243\n"; |
fd291da9 JH |
1245 | } else { |
1246 | print "not ok 243\n"; | |
1247 | } | |
1248 | ||
1249 | # In most places these tests would succeed since \x8e does not | |
1250 | # in most character sets match 'i' or 'j' nor would \xce match | |
1251 | # 'I' or 'J', but strictly speaking these tests are here for | |
1252 | # the good of EBCDIC, so let's test these only there. | |
1253 | if (ord('i') == 0x89 && ord('J') == 0xd1) { # EBCDIC | |
1254 | if ("\x8e" !~ /[i-j]/) { | |
1255 | print "ok 244\n"; | |
1256 | } else { | |
1257 | print "not ok 244\n"; | |
1258 | } | |
1259 | if ("\xce" !~ /[I-J]/) { | |
1260 | print "ok 245\n"; | |
1261 | } else { | |
1262 | print "not ok 245\n"; | |
1263 | } | |
1264 | } else { | |
1265 | for (244..245) { | |
60425c38 | 1266 | print "ok $_ # Skip: only in EBCDIC\n"; |
fd291da9 | 1267 | } |
db615365 | 1268 | } |
4765795a JH |
1269 | |
1270 | print "not " unless "\x{ab}" =~ /\x{ab}/; | |
1271 | print "ok 246\n"; | |
1272 | ||
1273 | print "not " unless "\x{abcd}" =~ /\x{abcd}/; | |
1274 | print "ok 247\n"; | |
1275 | ||
1276 | { | |
f9969324 JH |
1277 | # bug id 20001008.001 |
1278 | ||
1279 | my $test = 248; | |
1280 | my @x = ("stra\337e 138","stra\337e 138"); | |
1281 | for (@x) { | |
1282 | s/(\d+)\s*([\w\-]+)/$1 . uc $2/e; | |
1283 | my($latin) = /^(.+)(?:\s+\d)/; | |
1284 | print $latin eq "stra\337e" ? "ok $test\n" : # 248,249 | |
1285 | "#latin[$latin]\nnot ok $test\n"; | |
1286 | $test++; | |
1287 | $latin =~ s/stra\337e/straße/; # \303\237 after the 2nd a | |
1288 | use utf8; # needed for the raw UTF-8 | |
1289 | $latin =~ s!(s)tr(?:aß|s+e)!$1tr.!; # \303\237 after the a | |
4765795a JH |
1290 | } |
1291 | } | |
1292 | ||
1293 | { | |
1294 | print "not " unless "ba\xd4c" =~ /([a\xd4]+)/ && $1 eq "a\xd4"; | |
1295 | print "ok 250\n"; | |
1296 | ||
1297 | print "not " unless "ba\xd4c" =~ /([a\xd4]+)/ && $1 eq "a\x{d4}"; | |
1298 | print "ok 251\n"; | |
1299 | ||
1300 | print "not " unless "ba\x{d4}c" =~ /([a\xd4]+)/ && $1 eq "a\x{d4}"; | |
1301 | print "ok 252\n"; | |
1302 | ||
1303 | print "not " unless "ba\x{d4}c" =~ /([a\xd4]+)/ && $1 eq "a\xd4"; | |
1304 | print "ok 253\n"; | |
1305 | ||
1306 | print "not " unless "ba\xd4c" =~ /([a\x{d4}]+)/ && $1 eq "a\xd4"; | |
1307 | print "ok 254\n"; | |
1308 | ||
1309 | print "not " unless "ba\xd4c" =~ /([a\x{d4}]+)/ && $1 eq "a\x{d4}"; | |
1310 | print "ok 255\n"; | |
1311 | ||
1312 | print "not " unless "ba\x{d4}c" =~ /([a\x{d4}]+)/ && $1 eq "a\x{d4}"; | |
1313 | print "ok 256\n"; | |
1314 | ||
1315 | print "not " unless "ba\x{d4}c" =~ /([a\x{d4}]+)/ && $1 eq "a\xd4"; | |
1316 | print "ok 257\n"; | |
1317 | } | |
1318 | ||
1319 | { | |
1320 | # the first half of 20001028.003 | |
1321 | ||
1322 | my $X = chr(1448); | |
1323 | my ($Y) = $X =~ /(.*)/; | |
1324 | print "not " unless $Y eq v1448 && length($Y) == 1; | |
1325 | print "ok 258\n"; | |
1326 | } | |
1327 | ||
1328 | { | |
1329 | # 20001108.001 | |
1330 | ||
1331 | my $X = "Szab\x{f3},Bal\x{e1}zs"; | |
1332 | my $Y = $X; | |
1333 | $Y =~ s/(B)/$1/ for 0..3; | |
1334 | print "not " unless $Y eq $X && $X eq "Szab\x{f3},Bal\x{e1}zs"; | |
1335 | print "ok 259\n"; | |
1336 | } | |
1337 | ||
1338 | { | |
1339 | # the second half of 20001028.003 | |
1340 | ||
3568d838 | 1341 | my $X = ''; |
4765795a JH |
1342 | $X =~ s/^/chr(1488)/e; |
1343 | print "not " unless length $X == 1 && ord($X) == 1488; | |
1344 | print "ok 260\n"; | |
1345 | } | |
1346 | ||
1347 | { | |
1348 | # 20000517.001 | |
1349 | ||
1350 | my $x = "\x{100}A"; | |
1351 | ||
1352 | $x =~ s/A/B/; | |
1353 | ||
1354 | print "not " unless $x eq "\x{100}B" && length($x) == 2; | |
1355 | print "ok 261\n"; | |
1356 | } | |
1357 | ||
1358 | { | |
1359 | # bug id 20001230.002 | |
1360 | ||
1361 | print "not " unless "École" =~ /^\C\C(.)/ && $1 eq 'c'; | |
1362 | print "ok 262\n"; | |
1363 | ||
1364 | print "not " unless "École" =~ /^\C\C(c)/; | |
1365 | print "ok 263\n"; | |
1366 | } | |
1367 | ||
8dcad4ad | 1368 | SKIP: { |
4765795a JH |
1369 | my $test = 264; # till 575 |
1370 | ||
bb99e5f1 | 1371 | use charnames ":full"; |
4765795a JH |
1372 | |
1373 | # This is far from complete testing, there are dozens of character | |
1374 | # classes in Unicode. The mixing of literals and \N{...} is | |
1375 | # intentional so that in non-Latin-1 places we test the native | |
1376 | # characters, not the Unicode code points. | |
1377 | ||
1378 | my %s = ( | |
1379 | "a" => 'Ll', | |
1380 | "\N{CYRILLIC SMALL LETTER A}" => 'Ll', | |
1381 | "A" => 'Lu', | |
1382 | "\N{GREEK CAPITAL LETTER ALPHA}" => 'Lu', | |
1383 | "\N{HIRAGANA LETTER SMALL A}" => 'Lo', | |
1384 | "\N{COMBINING GRAVE ACCENT}" => 'Mn', | |
1385 | "0" => 'Nd', | |
1386 | "\N{ARABIC-INDIC DIGIT ZERO}" => 'Nd', | |
1387 | "_" => 'N', | |
1388 | "!" => 'P', | |
1389 | " " => 'Zs', | |
1390 | "\0" => 'Cc', | |
1391 | ); | |
73d6d589 | 1392 | |
3568d838 JH |
1393 | for my $char (map { s/^\S+ //; $_ } |
1394 | sort map { sprintf("%06x", ord($_))." $_" } keys %s) { | |
4765795a | 1395 | my $class = $s{$char}; |
3568d838 JH |
1396 | my $code = sprintf("%06x", ord($char)); |
1397 | printf "#\n# 0x$code\n#\n"; | |
4765795a JH |
1398 | print "# IsAlpha\n"; |
1399 | if ($class =~ /^[LM]/) { | |
1400 | print "not " unless $char =~ /\p{IsAlpha}/; | |
1401 | print "ok $test\n"; $test++; | |
1402 | print "not " if $char =~ /\P{IsAlpha}/; | |
1403 | print "ok $test\n"; $test++; | |
1404 | } else { | |
1405 | print "not " if $char =~ /\p{IsAlpha}/; | |
1406 | print "ok $test\n"; $test++; | |
1407 | print "not " unless $char =~ /\P{IsAlpha}/; | |
1408 | print "ok $test\n"; $test++; | |
1409 | } | |
1410 | print "# IsAlnum\n"; | |
1411 | if ($class =~ /^[LMN]/ && $char ne "_") { | |
1412 | print "not " unless $char =~ /\p{IsAlnum}/; | |
1413 | print "ok $test\n"; $test++; | |
1414 | print "not " if $char =~ /\P{IsAlnum}/; | |
1415 | print "ok $test\n"; $test++; | |
1416 | } else { | |
1417 | print "not " if $char =~ /\p{IsAlnum}/; | |
1418 | print "ok $test\n"; $test++; | |
1419 | print "not " unless $char =~ /\P{IsAlnum}/; | |
1420 | print "ok $test\n"; $test++; | |
1421 | } | |
1422 | print "# IsASCII\n"; | |
24817587 JH |
1423 | if (ord("A") == 193) { |
1424 | print "ok $test # Skip: in EBCDIC\n"; $test++; | |
1425 | print "ok $test # Skip: in EBCDIC\n"; $test++; | |
4765795a | 1426 | } else { |
24817587 JH |
1427 | if ($code le '00007f') { |
1428 | print "not " unless $char =~ /\p{IsASCII}/; | |
1429 | print "ok $test\n"; $test++; | |
1430 | print "not " if $char =~ /\P{IsASCII}/; | |
1431 | print "ok $test\n"; $test++; | |
1432 | } else { | |
1433 | print "not " if $char =~ /\p{IsASCII}/; | |
1434 | print "ok $test\n"; $test++; | |
1435 | print "not " unless $char =~ /\P{IsASCII}/; | |
1436 | print "ok $test\n"; $test++; | |
1437 | } | |
4765795a JH |
1438 | } |
1439 | print "# IsCntrl\n"; | |
1440 | if ($class =~ /^C/) { | |
1441 | print "not " unless $char =~ /\p{IsCntrl}/; | |
1442 | print "ok $test\n"; $test++; | |
1443 | print "not " if $char =~ /\P{IsCntrl}/; | |
1444 | print "ok $test\n"; $test++; | |
1445 | } else { | |
1446 | print "not " if $char =~ /\p{IsCntrl}/; | |
1447 | print "ok $test\n"; $test++; | |
1448 | print "not " unless $char =~ /\P{IsCntrl}/; | |
1449 | print "ok $test\n"; $test++; | |
1450 | } | |
1451 | print "# IsBlank\n"; | |
1452 | if ($class =~ /^Z[lp]/ || $char eq " ") { | |
1453 | print "not " unless $char =~ /\p{IsBlank}/; | |
1454 | print "ok $test\n"; $test++; | |
1455 | print "not " if $char =~ /\P{IsBlank}/; | |
1456 | print "ok $test\n"; $test++; | |
1457 | } else { | |
1458 | print "not " if $char =~ /\p{IsBlank}/; | |
1459 | print "ok $test\n"; $test++; | |
1460 | print "not " unless $char =~ /\P{IsBlank}/; | |
1461 | print "ok $test\n"; $test++; | |
1462 | } | |
1463 | print "# IsDigit\n"; | |
1464 | if ($class =~ /^Nd$/) { | |
1465 | print "not " unless $char =~ /\p{IsDigit}/; | |
1466 | print "ok $test\n"; $test++; | |
1467 | print "not " if $char =~ /\P{IsDigit}/; | |
1468 | print "ok $test\n"; $test++; | |
1469 | } else { | |
1470 | print "not " if $char =~ /\p{IsDigit}/; | |
1471 | print "ok $test\n"; $test++; | |
1472 | print "not " unless $char =~ /\P{IsDigit}/; | |
1473 | print "ok $test\n"; $test++; | |
1474 | } | |
1475 | print "# IsGraph\n"; | |
1476 | if ($class =~ /^([LMNPS])|Co/) { | |
1477 | print "not " unless $char =~ /\p{IsGraph}/; | |
1478 | print "ok $test\n"; $test++; | |
1479 | print "not " if $char =~ /\P{IsGraph}/; | |
1480 | print "ok $test\n"; $test++; | |
1481 | } else { | |
1482 | print "not " if $char =~ /\p{IsGraph}/; | |
1483 | print "ok $test\n"; $test++; | |
1484 | print "not " unless $char =~ /\P{IsGraph}/; | |
1485 | print "ok $test\n"; $test++; | |
1486 | } | |
1487 | print "# IsLower\n"; | |
1488 | if ($class =~ /^Ll$/) { | |
1489 | print "not " unless $char =~ /\p{IsLower}/; | |
1490 | print "ok $test\n"; $test++; | |
1491 | print "not " if $char =~ /\P{IsLower}/; | |
1492 | print "ok $test\n"; $test++; | |
1493 | } else { | |
1494 | print "not " if $char =~ /\p{IsLower}/; | |
1495 | print "ok $test\n"; $test++; | |
1496 | print "not " unless $char =~ /\P{IsLower}/; | |
1497 | print "ok $test\n"; $test++; | |
1498 | } | |
1499 | print "# IsPrint\n"; | |
1500 | if ($class =~ /^([LMNPS])|Co|Zs/) { | |
1501 | print "not " unless $char =~ /\p{IsPrint}/; | |
1502 | print "ok $test\n"; $test++; | |
1503 | print "not " if $char =~ /\P{IsPrint}/; | |
1504 | print "ok $test\n"; $test++; | |
1505 | } else { | |
1506 | print "not " if $char =~ /\p{IsPrint}/; | |
1507 | print "ok $test\n"; $test++; | |
1508 | print "not " unless $char =~ /\P{IsPrint}/; | |
1509 | print "ok $test\n"; $test++; | |
1510 | } | |
1511 | print "# IsPunct\n"; | |
1512 | if ($class =~ /^P/ || $char eq "_") { | |
1513 | print "not " unless $char =~ /\p{IsPunct}/; | |
1514 | print "ok $test\n"; $test++; | |
1515 | print "not " if $char =~ /\P{IsPunct}/; | |
1516 | print "ok $test\n"; $test++; | |
1517 | } else { | |
1518 | print "not " if $char =~ /\p{IsPunct}/; | |
1519 | print "ok $test\n"; $test++; | |
1520 | print "not " unless $char =~ /\P{IsPunct}/; | |
1521 | print "ok $test\n"; $test++; | |
1522 | } | |
1523 | print "# IsSpace\n"; | |
1524 | if ($class =~ /^Z/ || ($code =~ /^(0009|000A|000B|000C|000D)$/)) { | |
1525 | print "not " unless $char =~ /\p{IsSpace}/; | |
1526 | print "ok $test\n"; $test++; | |
1527 | print "not " if $char =~ /\P{IsSpace}/; | |
1528 | print "ok $test\n"; $test++; | |
1529 | } else { | |
1530 | print "not " if $char =~ /\p{IsSpace}/; | |
1531 | print "ok $test\n"; $test++; | |
1532 | print "not " unless $char =~ /\P{IsSpace}/; | |
1533 | print "ok $test\n"; $test++; | |
1534 | } | |
1535 | print "# IsUpper\n"; | |
1536 | if ($class =~ /^L[ut]/) { | |
1537 | print "not " unless $char =~ /\p{IsUpper}/; | |
1538 | print "ok $test\n"; $test++; | |
1539 | print "not " if $char =~ /\P{IsUpper}/; | |
1540 | print "ok $test\n"; $test++; | |
1541 | } else { | |
1542 | print "not " if $char =~ /\p{IsUpper}/; | |
1543 | print "ok $test\n"; $test++; | |
1544 | print "not " unless $char =~ /\P{IsUpper}/; | |
1545 | print "ok $test\n"; $test++; | |
1546 | } | |
1547 | print "# IsWord\n"; | |
1548 | if ($class =~ /^[LMN]/ || $char eq "_") { | |
1549 | print "not " unless $char =~ /\p{IsWord}/; | |
1550 | print "ok $test\n"; $test++; | |
1551 | print "not " if $char =~ /\P{IsWord}/; | |
1552 | print "ok $test\n"; $test++; | |
1553 | } else { | |
1554 | print "not " if $char =~ /\p{IsWord}/; | |
1555 | print "ok $test\n"; $test++; | |
1556 | print "not " unless $char =~ /\P{IsWord}/; | |
1557 | print "ok $test\n"; $test++; | |
1558 | } | |
1559 | } | |
1560 | } | |
1561 | ||
1562 | { | |
1563 | $_ = "abc\x{100}\x{200}\x{300}\x{380}\x{400}defg"; | |
1564 | ||
1565 | if (/(.\x{300})./) { | |
1566 | print "ok 576\n"; | |
1567 | ||
1568 | print "not " unless $` eq "abc\x{100}" && length($`) == 4; | |
73d6d589 | 1569 | print "ok 577\n"; |
4765795a JH |
1570 | |
1571 | print "not " unless $& eq "\x{200}\x{300}\x{380}" && length($&) == 3; | |
73d6d589 | 1572 | print "ok 578\n"; |
4765795a JH |
1573 | |
1574 | print "not " unless $' eq "\x{400}defg" && length($') == 5; | |
73d6d589 | 1575 | print "ok 579\n"; |
4765795a JH |
1576 | |
1577 | print "not " unless $1 eq "\x{200}\x{300}" && length($1) == 2; | |
73d6d589 | 1578 | print "ok 580\n"; |
a8a2fe91 JH |
1579 | } else { |
1580 | for (576..580) { print "not ok $_\n" } | |
4765795a JH |
1581 | } |
1582 | } | |
8269fa76 JH |
1583 | |
1584 | { | |
1585 | # bug id 20010306.008 | |
1586 | ||
1587 | $a = "a\x{1234}"; | |
1588 | # The original bug report had 'no utf8' here but that was irrelevant. | |
1589 | $a =~ m/\w/; # used to core dump | |
1590 | ||
1591 | print "ok 581\n"; | |
1592 | } | |
b8ef571c JH |
1593 | |
1594 | { | |
339e86bc JH |
1595 | $test = 582; |
1596 | ||
b8ef571c JH |
1597 | # bugid 20010410.006 |
1598 | for my $rx ( | |
1599 | '/(.*?)\{(.*?)\}/csg', | |
1600 | '/(.*?)\{(.*?)\}/cg', | |
1601 | '/(.*?)\{(.*?)\}/sg', | |
1602 | '/(.*?)\{(.*?)\}/g', | |
1603 | '/(.+?)\{(.+?)\}/csg', | |
1604 | ) | |
1605 | { | |
1606 | my($input, $i); | |
1607 | ||
1608 | $i = 0; | |
1609 | $input = "a{b}c{d}"; | |
1610 | eval <<EOT; | |
1611 | while (eval \$input =~ $rx) { | |
1612 | print "# \\\$1 = '\$1' \\\$2 = '\$2'\n"; | |
1613 | ++\$i; | |
1614 | } | |
1615 | EOT | |
1616 | print "not " unless $i == 2; | |
1617 | print "ok " . $test++ . "\n"; | |
1618 | } | |
1619 | } | |
209a9bc1 JH |
1620 | |
1621 | { | |
1622 | # from Robin Houston | |
1623 | ||
b851fbc1 | 1624 | my $x = "\x{10FFFD}"; |
209a9bc1 | 1625 | $x =~ s/(.)/$1/g; |
b851fbc1 | 1626 | print "not " unless ord($x) == 0x10FFFD && length($x) == 1; |
209a9bc1 JH |
1627 | print "ok 587\n"; |
1628 | } | |
3568d838 JH |
1629 | |
1630 | { | |
1631 | my $x = "\x7f"; | |
1632 | ||
1633 | print "not " if $x =~ /[\x80-\xff]/; | |
1634 | print "ok 588\n"; | |
1635 | ||
1636 | print "not " if $x =~ /[\x80-\x{100}]/; | |
1637 | print "ok 589\n"; | |
1638 | ||
1639 | print "not " if $x =~ /[\x{100}]/; | |
1640 | print "ok 590\n"; | |
1641 | ||
1642 | print "not " if $x =~ /\p{InLatin1Supplement}/; | |
1643 | print "ok 591\n"; | |
1644 | ||
1645 | print "not " unless $x =~ /\P{InLatin1Supplement}/; | |
1646 | print "ok 592\n"; | |
1647 | ||
1648 | print "not " if $x =~ /\p{InLatinExtendedA}/; | |
1649 | print "ok 593\n"; | |
1650 | ||
1651 | print "not " unless $x =~ /\P{InLatinExtendedA}/; | |
1652 | print "ok 594\n"; | |
1653 | } | |
1654 | ||
1655 | { | |
1656 | my $x = "\x80"; | |
1657 | ||
1658 | print "not " unless $x =~ /[\x80-\xff]/; | |
1659 | print "ok 595\n"; | |
1660 | ||
1661 | print "not " unless $x =~ /[\x80-\x{100}]/; | |
1662 | print "ok 596\n"; | |
1663 | ||
1664 | print "not " if $x =~ /[\x{100}]/; | |
1665 | print "ok 597\n"; | |
1666 | ||
1667 | print "not " unless $x =~ /\p{InLatin1Supplement}/; | |
1668 | print "ok 598\n"; | |
1669 | ||
1670 | print "not " if $x =~ /\P{InLatin1Supplement}/; | |
1671 | print "ok 599\n"; | |
1672 | ||
1673 | print "not " if $x =~ /\p{InLatinExtendedA}/; | |
1674 | print "ok 600\n"; | |
1675 | ||
1676 | print "not " unless $x =~ /\P{InLatinExtendedA}/; | |
1677 | print "ok 601\n"; | |
1678 | } | |
1679 | ||
1680 | { | |
1681 | my $x = "\xff"; | |
1682 | ||
1683 | print "not " unless $x =~ /[\x80-\xff]/; | |
1684 | print "ok 602\n"; | |
1685 | ||
1686 | print "not " unless $x =~ /[\x80-\x{100}]/; | |
1687 | print "ok 603\n"; | |
1688 | ||
1689 | print "not " if $x =~ /[\x{100}]/; | |
1690 | print "ok 604\n"; | |
1691 | ||
cc8040a1 TD |
1692 | # the next two tests must be ignored on EBCDIC |
1693 | print "not " unless $x =~ /\p{InLatin1Supplement}/ or ord("A") == 193; | |
3568d838 JH |
1694 | print "ok 605\n"; |
1695 | ||
cc8040a1 | 1696 | print "not " if $x =~ /\P{InLatin1Supplement}/ and ord("A") != 193; |
3568d838 JH |
1697 | print "ok 606\n"; |
1698 | ||
1699 | print "not " if $x =~ /\p{InLatinExtendedA}/; | |
1700 | print "ok 607\n"; | |
1701 | ||
1702 | print "not " unless $x =~ /\P{InLatinExtendedA}/; | |
1703 | print "ok 608\n"; | |
1704 | } | |
1705 | ||
1706 | { | |
1707 | my $x = "\x{100}"; | |
1708 | ||
1709 | print "not " if $x =~ /[\x80-\xff]/; | |
1710 | print "ok 609\n"; | |
1711 | ||
1712 | print "not " unless $x =~ /[\x80-\x{100}]/; | |
1713 | print "ok 610\n"; | |
1714 | ||
1715 | print "not " unless $x =~ /[\x{100}]/; | |
1716 | print "ok 611\n"; | |
1717 | ||
1718 | print "not " if $x =~ /\p{InLatin1Supplement}/; | |
1719 | print "ok 612\n"; | |
1720 | ||
1721 | print "not " unless $x =~ /\P{InLatin1Supplement}/; | |
1722 | print "ok 613\n"; | |
1723 | ||
1724 | print "not " unless $x =~ /\p{InLatinExtendedA}/; | |
1725 | print "ok 614\n"; | |
1726 | ||
1727 | print "not " if $x =~ /\P{InLatinExtendedA}/; | |
1728 | print "ok 615\n"; | |
1729 | } | |
1730 | ||
9d1d55b5 JP |
1731 | { |
1732 | # from japhy | |
1733 | my $w; | |
1734 | use warnings; | |
1735 | local $SIG{__WARN__} = sub { $w .= shift }; | |
1736 | ||
1737 | $w = ""; | |
1738 | eval 'qr/(?c)/'; | |
1739 | print "not " if $w !~ /^Useless \(\?c\)/; | |
1740 | print "ok 616\n"; | |
1741 | ||
1742 | $w = ""; | |
1743 | eval 'qr/(?-c)/'; | |
1744 | print "not " if $w !~ /^Useless \(\?-c\)/; | |
1745 | print "ok 617\n"; | |
1746 | ||
1747 | $w = ""; | |
1748 | eval 'qr/(?g)/'; | |
1749 | print "not " if $w !~ /^Useless \(\?g\)/; | |
1750 | print "ok 618\n"; | |
1751 | ||
1752 | $w = ""; | |
1753 | eval 'qr/(?-g)/'; | |
1754 | print "not " if $w !~ /^Useless \(\?-g\)/; | |
1755 | print "ok 619\n"; | |
1756 | ||
1757 | $w = ""; | |
1758 | eval 'qr/(?o)/'; | |
1759 | print "not " if $w !~ /^Useless \(\?o\)/; | |
1760 | print "ok 620\n"; | |
1761 | ||
1762 | $w = ""; | |
1763 | eval 'qr/(?-o)/'; | |
1764 | print "not " if $w !~ /^Useless \(\?-o\)/; | |
1765 | print "ok 621\n"; | |
1766 | ||
1767 | # now test multi-error regexes | |
1768 | ||
1769 | $w = ""; | |
1770 | eval 'qr/(?g-o)/'; | |
1771 | print "not " if $w !~ /^Useless \(\?g\).*\nUseless \(\?-o\)/; | |
1772 | print "ok 622\n"; | |
1773 | ||
1774 | $w = ""; | |
1775 | eval 'qr/(?g-c)/'; | |
1776 | print "not " if $w !~ /^Useless \(\?g\).*\nUseless \(\?-c\)/; | |
1777 | print "ok 623\n"; | |
1778 | ||
1779 | $w = ""; | |
1780 | eval 'qr/(?o-cg)/'; # (?c) means (?g) error won't be thrown | |
1781 | print "not " if $w !~ /^Useless \(\?o\).*\nUseless \(\?-c\)/; | |
1782 | print "ok 624\n"; | |
1783 | ||
1784 | $w = ""; | |
1785 | eval 'qr/(?ogc)/'; | |
1786 | print "not " if $w !~ /^Useless \(\?o\).*\nUseless \(\?g\).*\nUseless \(\?c\)/; | |
1787 | print "ok 625\n"; | |
1788 | } | |
a72deede JH |
1789 | |
1790 | # More Unicode "class" tests | |
1791 | ||
1792 | { | |
1793 | use charnames ':full'; | |
1794 | ||
1795 | print "not " unless "\N{LATIN CAPITAL LETTER A}" =~ /\p{InBasicLatin}/; | |
1796 | print "ok 626\n"; | |
1797 | ||
1798 | print "not " unless "\N{LATIN CAPITAL LETTER A WITH GRAVE}" =~ /\p{InLatin1Supplement}/; | |
1799 | print "ok 627\n"; | |
1800 | ||
1801 | print "not " unless "\N{LATIN CAPITAL LETTER A WITH MACRON}" =~ /\p{InLatinExtendedA}/; | |
1802 | print "ok 628\n"; | |
1803 | ||
1804 | print "not " unless "\N{LATIN SMALL LETTER B WITH STROKE}" =~ /\p{InLatinExtendedB}/; | |
1805 | print "ok 629\n"; | |
1806 | ||
1807 | print "not " unless "\N{KATAKANA LETTER SMALL A}" =~ /\p{InKatakana}/; | |
1808 | print "ok 630\n"; | |
1809 | } | |
1810 | ||
6002328a JH |
1811 | $_ = "foo"; |
1812 | ||
1813 | eval <<"EOT"; die if $@; | |
1814 | /f | |
1815 | o\r | |
1816 | o | |
1817 | \$ | |
1818 | /x && print "ok 631\n"; | |
1819 | EOT | |
1820 | ||
1821 | eval <<"EOT"; die if $@; | |
1822 | /f | |
1823 | o | |
1824 | o | |
1825 | \$\r | |
1826 | /x && print "ok 632\n"; | |
1827 | EOT | |
1828 | ||
569b5e07 AB |
1829 | #test /o feature |
1830 | sub test_o { $_[0] =~/$_[1]/o; return $1} | |
1831 | if(test_o('abc','(.)..') eq 'a') { | |
395ddfe6 | 1832 | print "ok 633\n"; |
569b5e07 | 1833 | } else { |
395ddfe6 | 1834 | print "not ok 633\n"; |
569b5e07 AB |
1835 | } |
1836 | if(test_o('abc','..(.)') eq 'a') { | |
395ddfe6 | 1837 | print "ok 634\n"; |
569b5e07 | 1838 | } else { |
395ddfe6 | 1839 | print "not ok 634\n"; |
569b5e07 AB |
1840 | } |
1841 | ||
f79b3095 JH |
1842 | # 635..639: ID 20010619.003 (only the space character is |
1843 | # supposed to be [:print:], not the whole isprint()). | |
1844 | ||
1845 | print "not " if "\n" =~ /[[:print:]]/; | |
1846 | print "ok 635\n"; | |
1847 | ||
1848 | print "not " if "\t" =~ /[[:print:]]/; | |
1849 | print "ok 636\n"; | |
1850 | ||
e857312d | 1851 | # Amazingly vertical tabulator is the same in ASCII and EBCDIC. |
f79b3095 JH |
1852 | print "not " if "\014" =~ /[[:print:]]/; |
1853 | print "ok 637\n"; | |
1854 | ||
1855 | print "not " if "\r" =~ /[[:print:]]/; | |
1856 | print "ok 638\n"; | |
1857 | ||
1858 | print "not " unless " " =~ /[[:print:]]/; | |
1859 | print "ok 639\n"; | |
1860 | ||
a01268b5 JH |
1861 | ## |
1862 | ## Test basic $^N usage outside of a regex | |
1863 | ## | |
1864 | $x = "abcdef"; | |
1865 | $T="ok 640\n";if ($x =~ /cde/ and not defined $^N) {print $T} else {print "not $T"}; | |
1866 | $T="ok 641\n";if ($x =~ /(cde)/ and $^N eq "cde") {print $T} else {print "not $T"}; | |
1867 | $T="ok 642\n";if ($x =~ /(c)(d)(e)/ and $^N eq "e") {print $T} else {print "not $T"}; | |
1868 | $T="ok 643\n";if ($x =~ /(c(d)e)/ and $^N eq "cde") {print $T} else {print "not $T"}; | |
1869 | $T="ok 644\n";if ($x =~ /(foo)|(c(d)e)/ and $^N eq "cde") {print $T} else {print "not $T"}; | |
1870 | $T="ok 645\n";if ($x =~ /(c(d)e)|(foo)/ and $^N eq "cde") {print $T} else {print "not $T"}; | |
1871 | $T="ok 646\n";if ($x =~ /(c(d)e)|(abc)/ and $^N eq "abc") {print $T} else {print "not $T"}; | |
1872 | $T="ok 647\n";if ($x =~ /(c(d)e)|(abc)x/ and $^N eq "cde") {print $T} else {print "not $T"}; | |
1873 | $T="ok 648\n";if ($x =~ /(c(d)e)(abc)?/ and $^N eq "cde") {print $T} else {print "not $T"}; | |
1874 | $T="ok 649\n";if ($x =~ /(?:c(d)e)/ and $^N eq "d" ) {print $T} else {print "not $T"}; | |
1875 | $T="ok 650\n";if ($x =~ /(?:c(d)e)(?:f)/ and $^N eq "d" ) {print $T} else {print "not $T"}; | |
1876 | $T="ok 651\n";if ($x =~ /(?:([abc])|([def]))*/ and $^N eq "f" ){print $T} else {print "not $T"}; | |
1877 | $T="ok 652\n";if ($x =~ /(?:([ace])|([bdf]))*/ and $^N eq "f" ){print $T} else {print "not $T"}; | |
1878 | $T="ok 653\n";if ($x =~ /(([ace])|([bd]))*/ and $^N eq "e" ){print $T} else {print "not $T"}; | |
1879 | { | |
1880 | $T="ok 654\n";if($x =~ /(([ace])|([bdf]))*/ and $^N eq "f" ){print $T} else {print "not $T"}; | |
1881 | } | |
1882 | ## test to see if $^N is automatically localized -- it should now | |
1883 | ## have the value set in test 653 | |
1884 | $T="ok 655\n";if ($^N eq "e" ){print $T} else {print "not $T"}; | |
1885 | ||
1886 | ## | |
1887 | ## Now test inside (?{...}) | |
1888 | ## | |
1889 | $T="ok 656\n";if ($x =~ /a([abc])(?{$y=$^N})c/ and $y eq "b" ){print $T} else {print "not $T"}; | |
1890 | $T="ok 657\n";if ($x =~ /a([abc]+)(?{$y=$^N})d/ and $y eq "bc"){print $T} else {print "not $T"}; | |
1891 | $T="ok 658\n";if ($x =~ /a([abcdefg]+)(?{$y=$^N})d/ and $y eq "bc"){print $T} else {print "not $T"}; | |
1892 | $T="ok 659\n";if ($x =~ /(a([abcdefg]+)(?{$y=$^N})d)(?{$z=$^N})e/ and $y eq "bc" and $z eq "abcd") | |
1893 | {print $T} else {print "not $T"}; | |
1894 | $T="ok 660\n";if ($x =~ /(a([abcdefg]+)(?{$y=$^N})de)(?{$z=$^N})/ and $y eq "bc" and $z eq "abcde") | |
1895 | {print $T} else {print "not $T"}; | |
2796c109 JH |
1896 | |
1897 | # Test the Unicode script classes | |
1898 | ||
cf25bb62 | 1899 | print "not " unless chr(0x100) =~ /\p{IsLatin}/; # outside Latin-1 |
2796c109 JH |
1900 | print "ok 661\n"; |
1901 | ||
cf25bb62 | 1902 | print "not " unless chr(0x212b) =~ /\p{IsLatin}/; # Angstrom sign, very outside |
2796c109 JH |
1903 | print "ok 662\n"; |
1904 | ||
cf25bb62 | 1905 | print "not " unless chr(0x5d0) =~ /\p{IsHebrew}/; # inside InHebrew |
2796c109 JH |
1906 | print "ok 663\n"; |
1907 | ||
cf25bb62 | 1908 | print "not " unless chr(0xfb4f) =~ /\p{IsHebrew}/; # outside InHebrew |
2796c109 JH |
1909 | print "ok 664\n"; |
1910 | ||
7be0dac3 NC |
1911 | # # singleton (not in a range, this test must be ignored on EBCDIC) |
1912 | # print "not " unless chr(0xb5) =~ /\p{IsGreek}/ or ord("A") == 193; | |
1913 | # print "ok 665\n"; | |
1914 | print "ok 665 # 0xb5 moved from Greek to Common with Unicode 4.0.1\n"; | |
5f9563ea | 1915 | |
cf25bb62 | 1916 | print "not " unless chr(0x37a) =~ /\p{IsGreek}/; # singleton |
5f9563ea JH |
1917 | print "ok 666\n"; |
1918 | ||
cf25bb62 | 1919 | print "not " unless chr(0x386) =~ /\p{IsGreek}/; # singleton |
5f9563ea JH |
1920 | print "ok 667\n"; |
1921 | ||
cf25bb62 | 1922 | print "not " unless chr(0x387) =~ /\P{IsGreek}/; # not there |
5f9563ea JH |
1923 | print "ok 668\n"; |
1924 | ||
cf25bb62 | 1925 | print "not " unless chr(0x388) =~ /\p{IsGreek}/; # range |
5f9563ea JH |
1926 | print "ok 669\n"; |
1927 | ||
cf25bb62 | 1928 | print "not " unless chr(0x38a) =~ /\p{IsGreek}/; # range |
5f9563ea JH |
1929 | print "ok 670\n"; |
1930 | ||
cf25bb62 | 1931 | print "not " unless chr(0x38b) =~ /\P{IsGreek}/; # not there |
5f9563ea JH |
1932 | print "ok 671\n"; |
1933 | ||
cf25bb62 | 1934 | print "not " unless chr(0x38c) =~ /\p{IsGreek}/; # singleton |
5f9563ea JH |
1935 | print "ok 672\n"; |
1936 | ||
550cec39 | 1937 | if (ord("A") == 65) { |
7be5a6cf JF |
1938 | ## |
1939 | ## Test [:cntrl:]... | |
1940 | ## | |
1941 | ## Should probably put in tests for all the POSIX stuff, but not sure how to | |
1942 | ## guarantee a specific locale...... | |
1943 | ## | |
550cec39 JH |
1944 | $AllBytes = join('', map { chr($_) } 0..255); |
1945 | ($x = $AllBytes) =~ s/[[:cntrl:]]//g; | |
1946 | if ($x ne join('', map { chr($_) } 0x20..0x7E, 0x80..0xFF)) { | |
1947 | print "not "; | |
1948 | } | |
1949 | print "ok 673\n"; | |
1950 | ||
1951 | ($x = $AllBytes) =~ s/[^[:cntrl:]]//g; | |
1952 | if ($x ne join('', map { chr($_) } 0..0x1F, 0x7F)) { print "not " } | |
1953 | print "ok 674\n"; | |
1954 | } else { | |
1955 | print "ok $_ # Skip: EBCDIC\n" for 673..674; | |
1956 | } | |
f33976b4 DB |
1957 | |
1958 | # With /s modifier UTF8 chars were interpreted as bytes | |
1959 | { | |
1960 | my $a = "Hello \x{263A} World"; | |
1961 | ||
1962 | my @a = ($a =~ /./gs); | |
1963 | ||
1964 | print "not " unless $#a == 12; | |
1965 | print "ok 675\n"; | |
1966 | } | |
cce850e4 JH |
1967 | |
1968 | @a = ("foo\nbar" =~ /./g); | |
1969 | print "ok 676\n" if @a == 6 && "@a" eq "f o o b a r"; | |
1970 | ||
1971 | @a = ("foo\nbar" =~ /./gs); | |
1972 | print "ok 677\n" if @a == 7 && "@a" eq "f o o \n b a r"; | |
1973 | ||
1974 | @a = ("foo\nbar" =~ /\C/g); | |
1975 | print "ok 678\n" if @a == 7 && "@a" eq "f o o \n b a r"; | |
1976 | ||
1977 | @a = ("foo\nbar" =~ /\C/gs); | |
1978 | print "ok 679\n" if @a == 7 && "@a" eq "f o o \n b a r"; | |
1979 | ||
1980 | @a = ("foo\n\x{100}bar" =~ /./g); | |
1981 | print "ok 680\n" if @a == 7 && "@a" eq "f o o \x{100} b a r"; | |
1982 | ||
1983 | @a = ("foo\n\x{100}bar" =~ /./gs); | |
1984 | print "ok 681\n" if @a == 8 && "@a" eq "f o o \n \x{100} b a r"; | |
1985 | ||
1986 | ($a, $b) = map { chr } ord('A') == 65 ? (0xc4, 0x80) : (0x8c, 0x41); | |
1987 | ||
1988 | @a = ("foo\n\x{100}bar" =~ /\C/g); | |
1989 | print "ok 682\n" if @a == 9 && "@a" eq "f o o \n $a $b b a r"; | |
1990 | ||
1991 | @a = ("foo\n\x{100}bar" =~ /\C/gs); | |
1992 | print "ok 683\n" if @a == 9 && "@a" eq "f o o \n $a $b b a r"; | |
1993 | ||
0af80b60 HS |
1994 | { |
1995 | # [ID 20010814.004] pos() doesn't work when using =~m// in list context | |
1996 | $_ = "ababacadaea"; | |
1997 | $a = join ":", /b./gc; | |
1998 | $b = join ":", /a./gc; | |
1999 | $c = pos; | |
2000 | print "$a $b $c" eq 'ba:ba ad:ae 10' ? "ok 684\n" : "not ok 684\t# $a $b $c\n"; | |
2001 | } | |
d9f424b2 JH |
2002 | |
2003 | { | |
75685a94 JH |
2004 | # [ID 20010407.006] matching utf8 return values from functions does not work |
2005 | ||
d9f424b2 JH |
2006 | package ID_20010407_006; |
2007 | ||
2008 | sub x { | |
2009 | "a\x{1234}"; | |
2010 | } | |
2011 | ||
2012 | my $x = x; | |
2013 | my $y; | |
2014 | ||
2015 | $x =~ /(..)/; $y = $1; | |
2016 | print "not " unless length($y) == 2 && $y eq $x; | |
75685a94 | 2017 | print "ok 685\n"; |
d9f424b2 JH |
2018 | |
2019 | x =~ /(..)/; $y = $1; | |
2020 | print "not " unless length($y) == 2 && $y eq $x; | |
2021 | print "ok 686\n"; | |
2022 | } | |
a4c04bdc | 2023 | |
e2d8ce26 | 2024 | |
a4c04bdc NC |
2025 | my $test = 687; |
2026 | ||
2027 | # Force scalar context on the patern match | |
2028 | sub ok ($$) { | |
2029 | my($ok, $name) = @_; | |
2030 | ||
2031 | printf "%sok %d - %s\n", ($ok ? "" : "not "), $test, $name; | |
2032 | ||
2033 | printf "# Failed test at line %d\n", (caller)[2] unless $ok; | |
2034 | ||
2035 | $test++; | |
2036 | return $ok; | |
2037 | } | |
2038 | ||
2039 | { | |
2040 | # Check that \x## works. 5.6.1 and 5.005_03 fail some of these. | |
2041 | $x = "\x4e" . "E"; | |
2042 | ok ($x =~ /^\x4EE$/, "Check only 2 bytes of hex are matched."); | |
2043 | ||
2044 | $x = "\x4e" . "i"; | |
2045 | ok ($x =~ /^\x4Ei$/, "Check that invalid hex digit stops it (2)"); | |
2046 | ||
2047 | $x = "\x4" . "j"; | |
2048 | ok ($x =~ /^\x4j$/, "Check that invalid hex digit stops it (1)"); | |
2049 | ||
2050 | $x = "\x0" . "k"; | |
2051 | ok ($x =~ /^\xk$/, "Check that invalid hex digit stops it (0)"); | |
2052 | ||
2053 | $x = "\x0" . "x"; | |
2054 | ok ($x =~ /^\xx$/, "\\xx isn't to be treated as \\0"); | |
2055 | ||
2056 | $x = "\x0" . "xa"; | |
2057 | ok ($x =~ /^\xxa$/, "\\xxa isn't to be treated as \\xa"); | |
2058 | ||
2059 | $x = "\x9" . "_b"; | |
2060 | ok ($x =~ /^\x9_b$/, "\\x9_b isn't to be treated as \\x9b"); | |
2061 | ||
2062 | print "# and now again in [] ranges\n"; | |
2063 | ||
2064 | $x = "\x4e" . "E"; | |
2065 | ok ($x =~ /^[\x4EE]{2}$/, "Check only 2 bytes of hex are matched."); | |
2066 | ||
2067 | $x = "\x4e" . "i"; | |
2068 | ok ($x =~ /^[\x4Ei]{2}$/, "Check that invalid hex digit stops it (2)"); | |
2069 | ||
2070 | $x = "\x4" . "j"; | |
2071 | ok ($x =~ /^[\x4j]{2}$/, "Check that invalid hex digit stops it (1)"); | |
2072 | ||
2073 | $x = "\x0" . "k"; | |
2074 | ok ($x =~ /^[\xk]{2}$/, "Check that invalid hex digit stops it (0)"); | |
2075 | ||
2076 | $x = "\x0" . "x"; | |
2077 | ok ($x =~ /^[\xx]{2}$/, "\\xx isn't to be treated as \\0"); | |
2078 | ||
2079 | $x = "\x0" . "xa"; | |
2080 | ok ($x =~ /^[\xxa]{3}$/, "\\xxa isn't to be treated as \\xa"); | |
2081 | ||
2082 | $x = "\x9" . "_b"; | |
2083 | ok ($x =~ /^[\x9_b]{3}$/, "\\x9_b isn't to be treated as \\x9b"); | |
2084 | ||
2085 | } | |
2086 | ||
2087 | { | |
2088 | # Check that \x{##} works. 5.6.1 fails quite a few of these. | |
2089 | ||
2090 | $x = "\x9b"; | |
2091 | ok ($x =~ /^\x{9_b}$/, "\\x{9_b} is to be treated as \\x9b"); | |
2092 | ||
2093 | $x = "\x9b" . "y"; | |
2094 | ok ($x =~ /^\x{9_b}y$/, "\\x{9_b} is to be treated as \\x9b (again)"); | |
2095 | ||
2096 | $x = "\x9b" . "y"; | |
2097 | ok ($x =~ /^\x{9b_}y$/, "\\x{9b_} is to be treated as \\x9b"); | |
2098 | ||
2099 | $x = "\x9b" . "y"; | |
2100 | ok ($x =~ /^\x{9_bq}y$/, "\\x{9_bc} is to be treated as \\x9b"); | |
2101 | ||
2102 | $x = "\x0" . "y"; | |
2103 | ok ($x =~ /^\x{x9b}y$/, "\\x{x9b} is to be treated as \\x0"); | |
2104 | ||
2105 | $x = "\x0" . "y"; | |
2106 | ok ($x =~ /^\x{0x9b}y$/, "\\x{0x9b} is to be treated as \\x0"); | |
2107 | ||
2108 | $x = "\x9b" . "y"; | |
2109 | ok ($x =~ /^\x{09b}y$/, "\\x{09b} is to be treated as \\x9b"); | |
2110 | ||
2111 | print "# and now again in [] ranges\n"; | |
2112 | ||
2113 | $x = "\x9b"; | |
2114 | ok ($x =~ /^[\x{9_b}]$/, "\\x{9_b} is to be treated as \\x9b"); | |
2115 | ||
2116 | $x = "\x9b" . "y"; | |
2117 | ok ($x =~ /^[\x{9_b}y]{2}$/, "\\x{9_b} is to be treated as \\x9b (again)"); | |
2118 | ||
2119 | $x = "\x9b" . "y"; | |
2120 | ok ($x =~ /^[\x{9b_}y]{2}$/, "\\x{9b_} is to be treated as \\x9b"); | |
2121 | ||
2122 | $x = "\x9b" . "y"; | |
2123 | ok ($x =~ /^[\x{9_bq}y]{2}$/, "\\x{9_bc} is to be treated as \\x9b"); | |
2124 | ||
2125 | $x = "\x0" . "y"; | |
2126 | ok ($x =~ /^[\x{x9b}y]{2}$/, "\\x{x9b} is to be treated as \\x0"); | |
2127 | ||
2128 | $x = "\x0" . "y"; | |
2129 | ok ($x =~ /^[\x{0x9b}y]{2}$/, "\\x{0x9b} is to be treated as \\x0"); | |
2130 | ||
2131 | $x = "\x9b" . "y"; | |
2132 | ok ($x =~ /^[\x{09b}y]{2}$/, "\\x{09b} is to be treated as \\x9b"); | |
2133 | } | |
e2d8ce26 JP |
2134 | |
2135 | { | |
d9efae67 JH |
2136 | # high bit bug -- japhy |
2137 | my $x = "ab\200d"; | |
2138 | $x =~ /.*?\200/ or print "not "; | |
2139 | print "ok 715\n"; | |
e2d8ce26 JP |
2140 | } |
2141 | ||
4193bef7 JH |
2142 | print "# some Unicode properties\n"; |
2143 | ||
d9efae67 | 2144 | { |
4193bef7 | 2145 | # Dashes, underbars, case. |
d9efae67 JH |
2146 | print "not " unless "\x80" =~ /\p{in-latin1_SUPPLEMENT}/; |
2147 | print "ok 716\n"; | |
ab13f0c7 | 2148 | |
4193bef7 | 2149 | # Complement, leading and trailing whitespace. |
ab13f0c7 JH |
2150 | print "not " unless "\x80" =~ /\P{ ^ In Latin 1 Supplement }/; |
2151 | print "ok 717\n"; | |
4193bef7 | 2152 | |
f173cd49 JH |
2153 | # No ^In, dashes, case, dash, any intervening (word-break) whitespace. |
2154 | # (well, newlines don't work...) | |
2155 | print "not " unless "\x80" =~ /\p{latin-1 supplement}/; | |
4193bef7 JH |
2156 | print "ok 718\n"; |
2157 | } | |
2158 | ||
2159 | { | |
2160 | print "not " unless "a" =~ /\pL/; | |
2161 | print "ok 719\n"; | |
4193bef7 | 2162 | |
4193bef7 JH |
2163 | print "not " unless "a" =~ /\p{IsLl}/; |
2164 | print "ok 720\n"; | |
4193bef7 | 2165 | |
c87b7cc2 | 2166 | print "not " if "a" =~ /\p{IsLu}/; |
4193bef7 | 2167 | print "ok 721\n"; |
4193bef7 | 2168 | |
61247495 | 2169 | print "not " unless "a" =~ /\p{Ll}/; |
4193bef7 | 2170 | print "ok 722\n"; |
c87b7cc2 | 2171 | |
61247495 | 2172 | print "not " if "a" =~ /\p{Lu}/; |
c87b7cc2 JH |
2173 | print "ok 723\n"; |
2174 | ||
61247495 | 2175 | print "not " unless "A" =~ /\pL/; |
c87b7cc2 JH |
2176 | print "ok 724\n"; |
2177 | ||
61247495 | 2178 | print "not " unless "A" =~ /\p{IsLu}/; |
c87b7cc2 JH |
2179 | print "ok 725\n"; |
2180 | ||
61247495 | 2181 | print "not " if "A" =~ /\p{IsLl}/; |
c87b7cc2 JH |
2182 | print "ok 726\n"; |
2183 | ||
61247495 | 2184 | print "not " unless "A" =~ /\p{Lu}/; |
c87b7cc2 JH |
2185 | print "ok 727\n"; |
2186 | ||
61247495 | 2187 | print "not " if "A" =~ /\p{Ll}/; |
c87b7cc2 JH |
2188 | print "ok 728\n"; |
2189 | ||
61247495 | 2190 | print "not " if "a" =~ /\PL/; |
c87b7cc2 JH |
2191 | print "ok 729\n"; |
2192 | ||
61247495 | 2193 | print "not " if "a" =~ /\P{IsLl}/; |
c87b7cc2 | 2194 | print "ok 730\n"; |
61247495 JH |
2195 | |
2196 | print "not " unless "a" =~ /\P{IsLu}/; | |
2197 | print "ok 731\n"; | |
2198 | ||
2199 | print "not " if "a" =~ /\P{Ll}/; | |
2200 | print "ok 732\n"; | |
2201 | ||
2202 | print "not " unless "a" =~ /\P{Lu}/; | |
2203 | print "ok 733\n"; | |
2204 | ||
2205 | print "not " if "A" =~ /\PL/; | |
2206 | print "ok 734\n"; | |
2207 | ||
2208 | print "not " if "A" =~ /\P{IsLu}/; | |
2209 | print "ok 735\n"; | |
2210 | ||
2211 | print "not " unless "A" =~ /\P{IsLl}/; | |
2212 | print "ok 736\n"; | |
2213 | ||
2214 | print "not " if "A" =~ /\P{Lu}/; | |
2215 | print "ok 737\n"; | |
2216 | ||
2217 | print "not " unless "A" =~ /\P{Ll}/; | |
2218 | print "ok 738\n"; | |
2219 | ||
4193bef7 | 2220 | } |
9b4e380a JH |
2221 | |
2222 | { | |
2223 | print "not " if "a" =~ /\p{Common}/; | |
2224 | print "ok 739\n"; | |
2225 | ||
2226 | print "not " unless "1" =~ /\p{Common}/; | |
2227 | print "ok 740\n"; | |
2228 | } | |
2229 | ||
2230 | { | |
2231 | print "not " if "a" =~ /\p{Inherited}/; | |
2232 | print "ok 741\n"; | |
2233 | ||
2234 | print "not " unless "\x{300}" =~ /\p{Inherited}/; | |
2235 | print "ok 742\n"; | |
2236 | } | |
2237 | ||
2238 | { | |
12ac2576 JP |
2239 | # L& and LC are the same |
2240 | print "not " unless "a" =~ /\p{LC}/ and "a" =~ /\p{L&}/; | |
9b4e380a JH |
2241 | print "ok 743\n"; |
2242 | ||
12ac2576 | 2243 | print "not " if "1" =~ /\p{LC}/ or "1" =~ /\p{L&}/; |
9b4e380a JH |
2244 | print "ok 744\n"; |
2245 | } | |
d73e5302 JH |
2246 | |
2247 | { | |
904bc114 | 2248 | print "not " unless "a" =~ /\p{Lowercase Letter}/; |
d73e5302 JH |
2249 | print "ok 745\n"; |
2250 | ||
904bc114 | 2251 | print "not " if "A" =~ /\p{lowercaseletter}/; |
d73e5302 JH |
2252 | print "ok 746\n"; |
2253 | } | |
2254 | ||
2255 | { | |
cf25bb62 | 2256 | print "not " unless "\x{AC00}" =~ /\p{HangulSyllables}/; |
d73e5302 JH |
2257 | print "ok 747\n"; |
2258 | } | |
71d929cb JH |
2259 | |
2260 | { | |
701a277b JH |
2261 | # Script=, Block=, Category= |
2262 | ||
71d929cb JH |
2263 | print "not " unless "\x{0100}" =~ /\p{Script=Latin}/; |
2264 | print "ok 748\n"; | |
2265 | ||
2266 | print "not " unless "\x{0100}" =~ /\p{Block=LatinExtendedA}/; | |
2267 | print "ok 749\n"; | |
2268 | ||
2269 | print "not " unless "\x{0100}" =~ /\p{Category=UppercaseLetter}/; | |
2270 | print "ok 750\n"; | |
2271 | } | |
2272 | ||
ef54fa25 | 2273 | { |
701a277b JH |
2274 | print "# the basic character classes and Unicode \n"; |
2275 | ||
ef54fa25 JH |
2276 | # 0100;LATIN CAPITAL LETTER A WITH MACRON;Lu;0;L;0041 0304;;;;N;LATIN CAPITAL LETTER A MACRON;;;0101; |
2277 | print "not " unless "\x{0100}" =~ /\w/; | |
2278 | print "ok 751\n"; | |
2279 | ||
2280 | # 0660;ARABIC-INDIC DIGIT ZERO;Nd;0;AN;;0;0;0;N;;;;; | |
2281 | print "not " unless "\x{0660}" =~ /\d/; | |
2282 | print "ok 752\n"; | |
2283 | ||
2284 | # 1680;OGHAM SPACE MARK;Zs;0;WS;;;;;N;;;;; | |
2285 | print "not " unless "\x{1680}" =~ /\s/; | |
2286 | print "ok 753\n"; | |
2287 | } | |
701a277b JH |
2288 | |
2289 | { | |
2290 | print "# folding matches and Unicode\n"; | |
2291 | ||
2292 | print "not " unless "a\x{100}" =~ /A/i; | |
2293 | print "ok 754\n"; | |
2294 | ||
27e28630 | 2295 | print "not " unless "A\x{100}" =~ /a/i; |
701a277b JH |
2296 | print "ok 755\n"; |
2297 | ||
2298 | print "not " unless "a\x{100}" =~ /a/i; | |
2299 | print "ok 756\n"; | |
2300 | ||
2301 | print "not " unless "A\x{100}" =~ /A/i; | |
2302 | print "ok 757\n"; | |
bc517b45 JH |
2303 | |
2304 | print "not " unless "\x{101}a" =~ /\x{100}/i; | |
2305 | print "ok 758\n"; | |
2306 | ||
2307 | print "not " unless "\x{100}a" =~ /\x{100}/i; | |
2308 | print "ok 759\n"; | |
2309 | ||
2310 | print "not " unless "\x{101}a" =~ /\x{101}/i; | |
2311 | print "ok 760\n"; | |
2312 | ||
2313 | print "not " unless "\x{100}a" =~ /\x{101}/i; | |
2314 | print "ok 761\n"; | |
2315 | ||
2316 | print "not " unless "a\x{100}" =~ /A\x{100}/i; | |
2317 | print "ok 762\n"; | |
2318 | ||
27e28630 | 2319 | print "not " unless "A\x{100}" =~ /a\x{100}/i; |
bc517b45 JH |
2320 | print "ok 763\n"; |
2321 | ||
2322 | print "not " unless "a\x{100}" =~ /a\x{100}/i; | |
2323 | print "ok 764\n"; | |
2324 | ||
2325 | print "not " unless "A\x{100}" =~ /A\x{100}/i; | |
2326 | print "ok 765\n"; | |
2327 | ||
2328 | print "not " unless "a\x{100}" =~ /[A]/i; | |
2329 | print "ok 766\n"; | |
2330 | ||
27e28630 | 2331 | print "not " unless "A\x{100}" =~ /[a]/i; |
bc517b45 JH |
2332 | print "ok 767\n"; |
2333 | ||
2334 | print "not " unless "a\x{100}" =~ /[a]/i; | |
2335 | print "ok 768\n"; | |
2336 | ||
2337 | print "not " unless "A\x{100}" =~ /[A]/i; | |
2338 | print "ok 769\n"; | |
2339 | ||
2340 | print "not " unless "\x{101}a" =~ /[\x{100}]/i; | |
2341 | print "ok 770\n"; | |
2342 | ||
2343 | print "not " unless "\x{100}a" =~ /[\x{100}]/i; | |
2344 | print "ok 771\n"; | |
2345 | ||
2346 | print "not " unless "\x{101}a" =~ /[\x{101}]/i; | |
2347 | print "ok 772\n"; | |
2348 | ||
2349 | print "not " unless "\x{100}a" =~ /[\x{101}]/i; | |
2350 | print "ok 773\n"; | |
2351 | ||
701a277b | 2352 | } |
a5961de5 JH |
2353 | |
2354 | { | |
2355 | use charnames ':full'; | |
2356 | ||
2357 | print "# LATIN LETTER A WITH GRAVE\n"; | |
2358 | my $lower = "\N{LATIN SMALL LETTER A WITH GRAVE}"; | |
2359 | my $UPPER = "\N{LATIN CAPITAL LETTER A WITH GRAVE}"; | |
2360 | ||
bc517b45 JH |
2361 | print $lower =~ m/$UPPER/i ? "ok 774\n" : "not ok 774\n"; |
2362 | print $UPPER =~ m/$lower/i ? "ok 775\n" : "not ok 775\n"; | |
2363 | print $lower =~ m/[$UPPER]/i ? "ok 776\n" : "not ok 776\n"; | |
2364 | print $UPPER =~ m/[$lower]/i ? "ok 777\n" : "not ok 777\n"; | |
a5961de5 JH |
2365 | |
2366 | print "# GREEK LETTER ALPHA WITH VRACHY\n"; | |
2367 | ||
2368 | $lower = "\N{GREEK CAPITAL LETTER ALPHA WITH VRACHY}"; | |
2369 | $UPPER = "\N{GREEK SMALL LETTER ALPHA WITH VRACHY}"; | |
2370 | ||
bc517b45 JH |
2371 | print $lower =~ m/$UPPER/i ? "ok 778\n" : "not ok 778\n"; |
2372 | print $UPPER =~ m/$lower/i ? "ok 779\n" : "not ok 779\n"; | |
2373 | print $lower =~ m/[$UPPER]/i ? "ok 780\n" : "not ok 780\n"; | |
2374 | print $UPPER =~ m/[$lower]/i ? "ok 781\n" : "not ok 781\n"; | |
a5961de5 JH |
2375 | |
2376 | print "# LATIN LETTER Y WITH DIAERESIS\n"; | |
2377 | ||
2378 | $lower = "\N{LATIN CAPITAL LETTER Y WITH DIAERESIS}"; | |
2379 | $UPPER = "\N{LATIN SMALL LETTER Y WITH DIAERESIS}"; | |
bc517b45 JH |
2380 | print $lower =~ m/$UPPER/i ? "ok 782\n" : "not ok 782\n"; |
2381 | print $UPPER =~ m/$lower/i ? "ok 783\n" : "not ok 783\n"; | |
2382 | print $lower =~ m/[$UPPER]/i ? "ok 784\n" : "not ok 784\n"; | |
2383 | print $UPPER =~ m/[$lower]/i ? "ok 785\n" : "not ok 785\n"; | |
a5961de5 | 2384 | } |
55da9344 JH |
2385 | |
2386 | { | |
2387 | use warnings; | |
2388 | use charnames ':full'; | |
2389 | ||
2390 | print "# GREEK CAPITAL LETTER SIGMA vs COMBINING GREEK PERISPOMENI\n"; | |
2391 | ||
2392 | my $SIGMA = "\N{GREEK CAPITAL LETTER SIGMA}"; | |
d07ddd77 | 2393 | my $char = "\N{COMBINING GREEK PERISPOMENI}"; |
55da9344 | 2394 | |
bc517b45 JH |
2395 | # Before #13843 this was failing by matching falsely. |
2396 | print "_:$char:_" =~ m/_:$SIGMA:_/i ? "not ok 786\n" : "ok 786\n"; | |
55da9344 | 2397 | } |
b7c83a7e JH |
2398 | |
2399 | { | |
2400 | print "# \\X\n"; | |
2401 | ||
2402 | use charnames ':full'; | |
2403 | ||
eb08e2da JH |
2404 | print "a!" =~ /^(\X)!/ && $1 eq "a" ? |
2405 | "ok 787\n" : "not ok 787 # $1\n"; | |
2406 | print "\xDF!" =~ /^(\X)!/ && $1 eq "\xDF" ? | |
2407 | "ok 788\n" : "not ok 788 # $1\n"; | |
2408 | print "\x{100}!" =~ /^(\X)!/ && $1 eq "\x{100}" ? | |
2409 | "ok 789\n" : "not ok 789 # $1\n"; | |
2410 | print "\x{100}\x{300}!" =~ /^(\X)!/ && $1 eq "\x{100}\x{300}" ? | |
2411 | "ok 790\n" : "not ok 790 # $1\n"; | |
2412 | print "\N{LATIN CAPITAL LETTER E}!" =~ /^(\X)!/ && | |
2413 | $1 eq "\N{LATIN CAPITAL LETTER E}" ? | |
2414 | "ok 791\n" : "not ok 791 # $1\n"; | |
2415 | print "\N{LATIN CAPITAL LETTER E}\N{COMBINING GRAVE ACCENT}!" =~ | |
2416 | /^(\X)!/ && | |
2417 | $1 eq "\N{LATIN CAPITAL LETTER E}\N{COMBINING GRAVE ACCENT}" ? | |
2418 | "ok 792\n" : "not ok 792 # $1\n"; | |
b7c83a7e | 2419 | } |
112bedeb JH |
2420 | |
2421 | { | |
2422 | print "#\\C and \\X\n"; | |
2423 | ||
2424 | print "!abc!" =~ /a\Cc/ ? "ok 793\n" : "not ok 793\n"; | |
2425 | print "!abc!" =~ /a\Xc/ ? "ok 794\n" : "not ok 794\n"; | |
2426 | } | |
09091399 JH |
2427 | |
2428 | { | |
2429 | print "# FINAL SIGMA\n"; | |
2430 | ||
2431 | my $SIGMA = "\x{03A3}"; # CAPITAL | |
2432 | my $Sigma = "\x{03C2}"; # SMALL FINAL | |
2433 | my $sigma = "\x{03C3}"; # SMALL | |
2434 | ||
2435 | print $SIGMA =~ /$SIGMA/i ? "ok 795\n" : "not ok 795\n"; | |
2436 | print $SIGMA =~ /$Sigma/i ? "ok 796\n" : "not ok 796\n"; | |
2437 | print $SIGMA =~ /$sigma/i ? "ok 797\n" : "not ok 797\n"; | |
2438 | ||
2439 | print $Sigma =~ /$SIGMA/i ? "ok 798\n" : "not ok 798\n"; | |
2440 | print $Sigma =~ /$Sigma/i ? "ok 799\n" : "not ok 799\n"; | |
2441 | print $Sigma =~ /$sigma/i ? "ok 800\n" : "not ok 800\n"; | |
2442 | ||
2443 | print $sigma =~ /$SIGMA/i ? "ok 801\n" : "not ok 801\n"; | |
2444 | print $sigma =~ /$Sigma/i ? "ok 802\n" : "not ok 802\n"; | |
2445 | print $sigma =~ /$sigma/i ? "ok 803\n" : "not ok 803\n"; | |
2446 | ||
2447 | print $SIGMA =~ /[$SIGMA]/i ? "ok 804\n" : "not ok 804\n"; | |
2448 | print $SIGMA =~ /[$Sigma]/i ? "ok 805\n" : "not ok 805\n"; | |
2449 | print $SIGMA =~ /[$sigma]/i ? "ok 806\n" : "not ok 806\n"; | |
2450 | ||
2451 | print $Sigma =~ /[$SIGMA]/i ? "ok 807\n" : "not ok 807\n"; | |
2452 | print $Sigma =~ /[$Sigma]/i ? "ok 808\n" : "not ok 808\n"; | |
2453 | print $Sigma =~ /[$sigma]/i ? "ok 809\n" : "not ok 809\n"; | |
2454 | ||
2455 | print $sigma =~ /[$SIGMA]/i ? "ok 810\n" : "not ok 810\n"; | |
2456 | print $sigma =~ /[$Sigma]/i ? "ok 811\n" : "not ok 811\n"; | |
2457 | print $sigma =~ /[$sigma]/i ? "ok 812\n" : "not ok 812\n"; | |
2458 | } | |
e036fef9 JF |
2459 | |
2460 | { | |
2461 | print "# parlez-vous?\n"; | |
2462 | ||
2463 | use charnames ':full'; | |
2464 | ||
2465 | print "fran\N{LATIN SMALL LETTER C}ais" =~ | |
2466 | /fran.ais/ && | |
2467 | $& eq "francais" ? | |
2468 | "ok 813\n" : "not ok 813\n"; | |
2469 | ||
2470 | print "fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais" =~ | |
2471 | /fran.ais/ && | |
2472 | $& eq "fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais" ? | |
2473 | "ok 814\n" : "not ok 814\n"; | |
2474 | ||
2475 | print "fran\N{LATIN SMALL LETTER C}ais" =~ | |
2476 | /fran\Cais/ && | |
2477 | $& eq "francais" ? | |
2478 | "ok 815\n" : "not ok 815\n"; | |
2479 | ||
2480 | print "franc\N{COMBINING CEDILLA}ais" =~ | |
2481 | /franc\C\Cais/ ? # COMBINING CEDILLA is two bytes when encoded | |
2482 | "ok 816\n" : "not ok 816\n"; | |
2483 | ||
2484 | print "fran\N{LATIN SMALL LETTER C}ais" =~ | |
2485 | /fran\Xais/ && | |
2486 | $& eq "francais" ? | |
2487 | "ok 817\n" : "not ok 817\n"; | |
2488 | ||
2489 | print "fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais" =~ | |
2490 | /fran\Xais/ && | |
2491 | $& eq "fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais" ? | |
2492 | "ok 818\n" : "not ok 818\n"; | |
2493 | ||
2494 | print "franc\N{COMBINING CEDILLA}ais" =~ | |
2495 | /fran\Xais/ && | |
2496 | $& eq "franc\N{COMBINING CEDILLA}ais" ? | |
2497 | "ok 819\n" : "not ok 819\n"; | |
2498 | ||
2499 | print "fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais" =~ | |
2500 | /fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais/ && | |
2501 | $& eq "fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais" ? | |
2502 | "ok 820\n" : "not ok 820\n"; | |
2503 | ||
2504 | print "franc\N{COMBINING CEDILLA}ais" =~ | |
2505 | /franc\N{COMBINING CEDILLA}ais/ && | |
2506 | $& eq "franc\N{COMBINING CEDILLA}ais" ? | |
2507 | "ok 821\n" : "not ok 821\n"; | |
2508 | ||
2509 | print "fran\N{LATIN SMALL LETTER C}ais" =~ | |
2510 | /fran(?:c\N{COMBINING CEDILLA}?|\N{LATIN SMALL LETTER C WITH CEDILLA})ais/ && | |
2511 | $& eq "francais" ? | |
2512 | "ok 822\n" : "not ok 822\n"; | |
2513 | ||
2514 | print "fran\N{LATIN SMALL LETTER C}ais" =~ | |
2515 | /fran(?:c\N{COMBINING CEDILLA}?|\N{LATIN SMALL LETTER C WITH CEDILLA})ais/ && | |
2516 | $& eq "francais" ? | |
2517 | "ok 823\n" : "not ok 823\n"; | |
2518 | ||
2519 | print "fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais" =~ | |
2520 | /fran(?:c\N{COMBINING CEDILLA}?|\N{LATIN SMALL LETTER C WITH CEDILLA})ais/ && | |
2521 | $& eq "fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais" ? | |
2522 | "ok 824\n" : "not ok 824\n"; | |
2523 | ||
2524 | print "franc\N{COMBINING CEDILLA}ais" =~ | |
2525 | /fran(?:c\N{COMBINING CEDILLA}?|\N{LATIN SMALL LETTER C WITH CEDILLA})ais/ && | |
2526 | $& eq "franc\N{COMBINING CEDILLA}ais" ? | |
2527 | "ok 825\n" : "not ok 825\n"; | |
2528 | } | |
ffce6cc2 JH |
2529 | |
2530 | { | |
2531 | print "# Does lingering (and useless) UTF8 flag mess up /i matching?\n"; | |
2532 | ||
2533 | { | |
2534 | my $regex = "ABcde"; | |
2535 | my $string = "abcDE\x{100}"; | |
2536 | chop($string); | |
2537 | if ($string =~ m/$regex/i) { | |
2538 | print "ok 826\n"; | |
2539 | } else { | |
2540 | print "not ok 826\n"; | |
2541 | } | |
2542 | } | |
2543 | ||
2544 | { | |
2545 | my $regex = "ABcde\x{100}"; | |
2546 | my $string = "abcDE"; | |
2547 | chop($regex); | |
2548 | if ($string =~ m/$regex/i) { | |
2549 | print "ok 827\n"; | |
2550 | } else { | |
2551 | print "not ok 827\n"; | |
2552 | } | |
2553 | } | |
2554 | ||
2555 | { | |
2556 | my $regex = "ABcde\x{100}"; | |
2557 | my $string = "abcDE\x{100}"; | |
2558 | chop($regex); | |
2559 | chop($string); | |
2560 | if ($string =~ m/$regex/i) { | |
2561 | print "ok 828\n"; | |
2562 | } else { | |
2563 | print "not ok 828\n"; | |
2564 | } | |
2565 | } | |
2566 | } | |
d07ddd77 JH |
2567 | |
2568 | { | |
2569 | print "# more SIGMAs\n"; | |
2570 | ||
2571 | my $SIGMA = "\x{03A3}"; # CAPITAL | |
2572 | my $Sigma = "\x{03C2}"; # SMALL FINAL | |
2573 | my $sigma = "\x{03C3}"; # SMALL | |
2574 | ||
2575 | my $S3 = "$SIGMA$Sigma$sigma"; | |
2576 | ||
2577 | print ":$S3:" =~ /:(($SIGMA)+):/i && $1 eq $S3 && $2 eq $sigma ? | |
2578 | "ok 829\n" : "not ok 829\n"; | |
2579 | print ":$S3:" =~ /:(($Sigma)+):/i && $1 eq $S3 && $2 eq $sigma ? | |
2580 | "ok 830\n" : "not ok 830\n"; | |
2581 | print ":$S3:" =~ /:(($sigma)+):/i && $1 eq $S3 && $2 eq $sigma ? | |
2582 | "ok 831\n" : "not ok 831\n"; | |
2583 | ||
2584 | print ":$S3:" =~ /:(([$SIGMA])+):/i && $1 eq $S3 && $2 eq $sigma ? | |
2585 | "ok 832\n" : "not ok 832\n"; | |
2586 | print ":$S3:" =~ /:(([$Sigma])+):/i && $1 eq $S3 && $2 eq $sigma ? | |
2587 | "ok 833\n" : "not ok 833\n"; | |
2588 | print ":$S3:" =~ /:(([$sigma])+):/i && $1 eq $S3 && $2 eq $sigma ? | |
2589 | "ok 834\n" : "not ok 834\n"; | |
2590 | } | |
925f9e00 JH |
2591 | |
2592 | { | |
2593 | print "# LATIN SMALL LETTER SHARP S\n"; | |
2594 | ||
2595 | use charnames ':full'; | |
2596 | ||
2597 | print "\N{LATIN SMALL LETTER SHARP S}" =~ | |
2598 | /\N{LATIN SMALL LETTER SHARP S}/ ? "ok 835\n" : "not ok 835\n"; | |
2599 | ||
2600 | print "\N{LATIN SMALL LETTER SHARP S}" =~ | |
2601 | /\N{LATIN SMALL LETTER SHARP S}/i ? "ok 836\n" : "not ok 836\n"; | |
2602 | ||
2603 | print "\N{LATIN SMALL LETTER SHARP S}" =~ | |
2604 | /[\N{LATIN SMALL LETTER SHARP S}]/ ? "ok 837\n" : "not ok 837\n"; | |
2605 | ||
2606 | print "\N{LATIN SMALL LETTER SHARP S}" =~ | |
2607 | /[\N{LATIN SMALL LETTER SHARP S}]/i ? "ok 838\n" : "not ok 838\n"; | |
2608 | ||
2609 | print "ss" =~ | |
2610 | /\N{LATIN SMALL LETTER SHARP S}/i ? "ok 839\n" : "not ok 839\n"; | |
2611 | ||
2612 | print "SS" =~ | |
2613 | /\N{LATIN SMALL LETTER SHARP S}/i ? "ok 840\n" : "not ok 840\n"; | |
2614 | ||
e0f9d4a8 JH |
2615 | print "ss" =~ |
2616 | /[\N{LATIN SMALL LETTER SHARP S}]/i ? "ok 841\n" : "not ok 841\n"; | |
2617 | ||
2618 | print "SS" =~ | |
2619 | /[\N{LATIN SMALL LETTER SHARP S}]/i ? "ok 842\n" : "not ok 842\n"; | |
5486206c JH |
2620 | |
2621 | print "\N{LATIN SMALL LETTER SHARP S}" =~ /ss/i ? | |
2622 | "ok 843\n" : "not ok 843\n"; | |
2623 | ||
2624 | print "\N{LATIN SMALL LETTER SHARP S}" =~ /SS/i ? | |
2625 | "ok 844\n" : "not ok 844\n"; | |
925f9e00 | 2626 | } |
d8f6a732 JH |
2627 | |
2628 | { | |
2629 | print "# more whitespace: U+0085, U+2028, U+2029\n"; | |
2630 | ||
2631 | # U+0085 needs to be forced to be Unicode, the \x{100} does that. | |
5486206c JH |
2632 | print "<\x{100}\x{0085}>" =~ /<\x{100}\s>/ ? "ok 845\n" : "not ok 845\n"; |
2633 | print "<\x{2028}>" =~ /<\s>/ ? "ok 846\n" : "not ok 846\n"; | |
2634 | print "<\x{2029}>" =~ /<\s>/ ? "ok 847\n" : "not ok 847\n"; | |
d8f6a732 JH |
2635 | } |
2636 | ||
def8e4ea | 2637 | { |
229196e5 | 2638 | print "# . with /s should work on characters, as opposed to bytes\n"; |
def8e4ea JH |
2639 | |
2640 | my $s = "\x{e4}\x{100}"; | |
2641 | ||
2642 | # This is not expected to match: the point is that | |
2643 | # neither should we get "Malformed UTF-8" warnings. | |
2644 | print $s =~ /\G(.+?)\n/gcs ? | |
5486206c | 2645 | "not ok 848\n" : "ok 848\n"; |
def8e4ea JH |
2646 | |
2647 | my @c; | |
2648 | ||
2649 | while ($s =~ /\G(.)/gs) { | |
2650 | push @c, $1; | |
2651 | } | |
2652 | ||
5486206c | 2653 | print join("", @c) eq $s ? "ok 849\n" : "not ok 849\n"; |
a0804c9e A |
2654 | |
2655 | my $t1 = "Q003\n\n\x{e4}\x{f6}\n\nQ004\n\n\x{e7}"; # test only chars < 256 | |
2656 | my $r1 = ""; | |
2657 | while ($t1 =~ / \G ( .+? ) \n\s+ ( .+? ) ( $ | \n\s+ ) /xgcs) { | |
2658 | $r1 .= $1 . $2; | |
2659 | } | |
2660 | ||
2661 | my $t2 = $t1 . "\x{100}"; # repeat with a larger char | |
2662 | my $r2 = ""; | |
2663 | while ($t2 =~ / \G ( .+? ) \n\s+ ( .+? ) ( $ | \n\s+ ) /xgcs) { | |
2664 | $r2 .= $1 . $2; | |
2665 | } | |
2666 | $r2 =~ s/\x{100}//; | |
5486206c | 2667 | print $r1 eq $r2 ? "ok 850\n" : "not ok 850\n"; |
def8e4ea | 2668 | } |
e54858b0 JH |
2669 | |
2670 | { | |
2671 | print "# Unicode lookbehind\n"; | |
2672 | ||
5486206c JH |
2673 | print "A\x{100}B" =~ /(?<=A.)B/ ? "ok 851\n" : "not ok 851\n"; |
2674 | print "A\x{200}\x{300}B" =~ /(?<=A..)B/ ? "ok 852\n" : "not ok 852\n"; | |
2675 | print "\x{400}AB" =~ /(?<=\x{400}.)B/ ? "ok 853\n" : "not ok 853\n"; | |
2676 | print "\x{500\x{600}}B" =~ /(?<=\x{500}.)B/ ? "ok 854\n" : "not ok 854\n"; | |
e54858b0 | 2677 | } |
c46248c1 JH |
2678 | |
2679 | { | |
85fd1718 JH |
2680 | print "# UTF-8 hash keys and /\$/\n"; |
2681 | # http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2002-01/msg01327.html | |
2682 | ||
2683 | my $u = "a\x{100}"; | |
2684 | my $v = substr($u,0,1); | |
2685 | my $w = substr($u,1,1); | |
2686 | my %u = ( $u => $u, $v => $v, $w => $w ); | |
8d21bda2 | 2687 | my $i = 855; |
85fd1718 JH |
2688 | for (keys %u) { |
2689 | my $m1 = /^\w*$/ ? 1 : 0; | |
2690 | my $m2 = $u{$_}=~/^\w*$/ ? 1 : 0; | |
2691 | print $m1 == $m2 ? "ok $i\n" : "not ok $i # $m1 $m2\n"; | |
2692 | $i++; | |
2693 | } | |
2694 | } | |
8d21bda2 JH |
2695 | |
2696 | { | |
2697 | print "# [ID 20020124.005]\n"; | |
2698 | # Fixed by #14795. | |
2699 | my $i = 858; | |
2700 | for my $char ("a", "\x{df}", "\x{100}"){ | |
2701 | $x = "$char b $char"; | |
2702 | $x =~ s{($char)}{ | |
2703 | "c" =~ /c/; | |
2704 | "x"; | |
2705 | }ge; | |
2706 | print substr($x,0,1) eq substr($x,-1,1) ? | |
2707 | "ok $i\n" : "not ok $i # debug: $x\n"; | |
2708 | $i++; | |
2709 | } | |
2710 | } | |
6e602e29 A |
2711 | |
2712 | { | |
2713 | print "# SEGV in s/// and UTF-8\n"; | |
2714 | $s = "s#\x{100}" x 4; | |
2715 | $s =~ s/[^\w]/ /g; | |
2716 | print $s eq "s \x{100}" x 4 ? "ok 861\n" : "not ok 861\n"; | |
2717 | } | |
f272994b A |
2718 | |
2719 | { | |
2720 | print "# UTF-8 bug (maybe alreayd known?)\n"; | |
2721 | my $u; | |
2722 | ||
2723 | $u = "foo"; | |
2724 | $u =~ s/./\x{100}/g; | |
2725 | print $u eq "\x{100}\x{100}\x{100}" ? "ok 862\n" : "not ok 862\n"; | |
2726 | ||
2727 | $u = "foobar"; | |
2728 | $u =~ s/[ao]/\x{100}/g; | |
2729 | print $u eq "f\x{100}\x{100}b\x{100}r" ? "ok 863\n" : "not ok 863\n"; | |
2730 | ||
2731 | $u =~ s/\x{100}/e/g; | |
2732 | print $u eq "feeber" ? "ok 864\n" : "not ok 864\n"; | |
2733 | } | |
2734 | ||
33b8afdf JH |
2735 | { |
2736 | print "# UTF-8 bug with s///\n"; | |
2737 | # check utf8/non-utf8 mixtures | |
2738 | # try to force all float/anchored check combinations | |
2739 | my $c = "\x{100}"; | |
2740 | my $test = 865; | |
2741 | my $subst; | |
2742 | for my $re ( | |
2743 | "xx.*$c", "x.*$c$c", "$c.*xx", "$c$c.*x", "xx.*(?=$c)", "(?=$c).*xx", | |
2744 | ) { | |
2745 | print "xxx" =~ /$re/ ? "not ok $test\n" : "ok $test\n"; | |
2746 | ++$test; | |
2747 | print +($subst = "xxx") =~ s/$re// ? "not ok $test\n" : "ok $test\n"; | |
2748 | ++$test; | |
2749 | } | |
2750 | for my $re ("xx.*$c*", "$c*.*xx") { | |
2751 | print "xxx" =~ /$re/ ? "ok $test\n" : "not ok $test\n"; | |
2752 | ++$test; | |
2753 | ($subst = "xxx") =~ s/$re//; | |
2754 | print $subst eq '' ? "ok $test\n" : "not ok $test\t# $subst\n"; | |
2755 | ++$test; | |
2756 | } | |
2757 | for my $re ("xxy*", "y*xx") { | |
2758 | print "xx$c" =~ /$re/ ? "ok $test\n" : "not ok $test\n"; | |
2759 | ++$test; | |
2760 | ($subst = "xx$c") =~ s/$re//; | |
2761 | print $subst eq $c ? "ok $test\n" : "not ok $test\n"; | |
2762 | ++$test; | |
2763 | print "xy$c" =~ /$re/ ? "not ok $test\n" : "ok $test\n"; | |
2764 | ++$test; | |
2765 | print +($subst = "xy$c") =~ /$re/ ? "not ok $test\n" : "ok $test\n"; | |
2766 | ++$test; | |
2767 | } | |
2768 | for my $re ("xy$c*z", "x$c*yz") { | |
2769 | print "xyz" =~ /$re/ ? "ok $test\n" : "not ok $test\n"; | |
2770 | ++$test; | |
2771 | ($subst = "xyz") =~ s/$re//; | |
2772 | print $subst eq '' ? "ok $test\n" : "not ok $test\n"; | |
2773 | ++$test; | |
2774 | } | |
2775 | } | |
574c8022 | 2776 | |
ff385a1b JF |
2777 | { |
2778 | print "# qr/.../x\n"; | |
4c79aee6 | 2779 | my $test = 893; |
ff385a1b JF |
2780 | |
2781 | my $R = qr/ A B C # D E/x; | |
2782 | ||
2783 | print eval {"ABCDE" =~ $R} ? "ok $test\n" : "not ok $test\n"; | |
2784 | $test++; | |
2785 | ||
2786 | print eval {"ABCDE" =~ m/$R/} ? "ok $test\n" : "not ok $test\n"; | |
2787 | $test++; | |
2788 | ||
2789 | print eval {"ABCDE" =~ m/($R)/} ? "ok $test\n" : "not ok $test\n"; | |
2790 | $test++; | |
2791 | } | |
bc45ce41 JH |
2792 | |
2793 | { | |
2794 | print "# illegal Unicode properties\n"; | |
4c79aee6 | 2795 | my $test = 896; |
bc45ce41 JH |
2796 | |
2797 | print eval { "a" =~ /\pq / } ? "not ok $test\n" : "ok $test\n"; | |
2798 | $test++; | |
2799 | ||
2800 | print eval { "a" =~ /\p{qrst} / } ? "not ok $test\n" : "ok $test\n"; | |
2801 | $test++; | |
2802 | } | |
d65afb4b HS |
2803 | |
2804 | { | |
491fd90a | 2805 | print "# [ID 20020412.005] wrong pmop flags checked when empty pattern\n"; |
d65afb4b HS |
2806 | # requires reuse of last successful pattern |
2807 | my $test = 898; | |
2808 | $test =~ /\d/; | |
2809 | for (0 .. 1) { | |
2810 | my $match = ?? + 0; | |
2811 | if ($match != $_) { | |
2812 | print "ok $test\n"; | |
2813 | } else { | |
2814 | printf "not ok %s\t# 'match once' %s on %s iteration\n", $test, | |
2815 | $match ? 'succeeded' : 'failed', $_ ? 'second' : 'first'; | |
2816 | } | |
2817 | ++$test; | |
2818 | } | |
2819 | $test =~ /(\d)/; | |
2820 | my $result = join '', $test =~ //g; | |
2821 | if ($result eq $test) { | |
2822 | print "ok $test\n"; | |
2823 | } else { | |
2824 | printf "not ok %s\t# expected '%s', got '%s'\n", $test, $test, $result; | |
2825 | } | |
2826 | ++$test; | |
2827 | } | |
491fd90a JH |
2828 | |
2829 | print "# user-defined character properties\n"; | |
2830 | ||
2831 | sub InKana1 { | |
2832 | return <<'END'; | |
2833 | 3040 309F | |
2834 | 30A0 30FF | |
2835 | END | |
2836 | } | |
2837 | ||
2838 | sub InKana2 { | |
2839 | return <<'END'; | |
2840 | +utf8::InHiragana | |
2841 | +utf8::InKatakana | |
2842 | END | |
2843 | } | |
2844 | ||
2845 | sub InKana3 { | |
2846 | return <<'END'; | |
2847 | +utf8::InHiragana | |
2848 | +utf8::InKatakana | |
2849 | -utf8::IsCn | |
2850 | END | |
2851 | } | |
2852 | ||
2853 | sub InNotKana { | |
2854 | return <<'END'; | |
2855 | !utf8::InHiragana | |
2856 | -utf8::InKatakana | |
2857 | +utf8::IsCn | |
2858 | END | |
2859 | } | |
2860 | ||
2861 | $test = 901; | |
2862 | ||
2863 | print "\x{3040}" =~ /\p{InKana1}/ ? "ok $test\n" : "not ok $test\n"; $test++; | |
2864 | print "\x{303F}" =~ /\P{InKana1}/ ? "ok $test\n" : "not ok $test\n"; $test++; | |
2865 | ||
2866 | print "\x{3040}" =~ /\p{InKana2}/ ? "ok $test\n" : "not ok $test\n"; $test++; | |
2867 | print "\x{303F}" =~ /\P{InKana2}/ ? "ok $test\n" : "not ok $test\n"; $test++; | |
2868 | ||
2869 | print "\x{3041}" =~ /\p{InKana3}/ ? "ok $test\n" : "not ok $test\n"; $test++; | |
2870 | print "\x{3040}" =~ /\P{InKana3}/ ? "ok $test\n" : "not ok $test\n"; $test++; | |
2871 | ||
2872 | print "\x{3040}" =~ /\p{InNotKana}/ ? "ok $test\n" : "not ok $test\n"; $test++; | |
2873 | print "\x{3041}" =~ /\P{InNotKana}/ ? "ok $test\n" : "not ok $test\n"; $test++; | |
2874 | ||
11ef8fdd JH |
2875 | sub InConsonant { # Not EBCDIC-aware. |
2876 | return <<EOF; | |
2877 | 0061 007f | |
2878 | -0061 | |
2879 | -0065 | |
2880 | -0069 | |
2881 | -006f | |
2882 | -0075 | |
2883 | EOF | |
2884 | } | |
2885 | ||
2886 | print "d" =~ /\p{InConsonant}/ ? "ok $test\n" : "not ok $test\n"; $test++; | |
2887 | print "e" =~ /\P{InConsonant}/ ? "ok $test\n" : "not ok $test\n"; $test++; | |
2888 | ||
faf11cac HS |
2889 | { |
2890 | print "# [ID 20020630.002] utf8 regex only matches 32k\n"; | |
2891 | $test = 911; | |
2892 | for ([ 'byte', "\x{ff}" ], [ 'utf8', "\x{1ff}" ]) { | |
2893 | my($type, $char) = @$_; | |
2894 | for my $len (32000, 32768, 33000) { | |
2895 | my $s = $char . "f" x $len; | |
2896 | my $r = $s =~ /$char([f]*)/gc; | |
2897 | print $r ? "ok $test\n" : "not ok $test\t# <$type x $len> fail\n"; | |
2898 | ++$test; | |
2899 | print +(!$r or pos($s) == $len + 1) ? "ok $test\n" | |
2900 | : "not ok $test\t# <$type x $len> pos @{[ pos($s) ]}\n"; | |
2901 | ++$test; | |
2902 | } | |
2903 | } | |
2904 | } | |
2905 | ||
2906 | $test = 923; | |
f3b1e556 YST |
2907 | |
2908 | $a = bless qr/foo/, 'Foo'; | |
2909 | print(('goodfood' =~ $a ? '' : 'not '), | |
2910 | "ok $test\t# reblessed qr// matches\n"); | |
2911 | ++$test; | |
2912 | ||
2913 | print(($a eq '(?-xism:foo)' ? '' : 'not '), | |
2914 | "ok $test\t# reblessed qr// stringizes\n"); | |
2915 | ++$test; | |
446eaa42 YST |
2916 | |
2917 | $x = "\x{3fe}"; | |
cb50f42d YST |
2918 | $z=$y = "\317\276"; # $y is byte representation of $x |
2919 | ||
446eaa42 YST |
2920 | $a = qr/$x/; |
2921 | print(($x =~ $a ? '' : 'not '), "ok $test - utf8 interpolation in qr//\n"); | |
2922 | ++$test; | |
2923 | ||
2924 | print(("a$a" =~ $x ? '' : 'not '), | |
cb50f42d YST |
2925 | "ok $test - stringifed qr// preserves utf8\n"); |
2926 | ++$test; | |
2927 | ||
2928 | print(("a$x" =~ /^a$a\z/ ? '' : 'not '), | |
2929 | "ok $test - interpolated qr// preserves utf8\n"); | |
2930 | ++$test; | |
2931 | ||
2932 | print(("a$x" =~ /^a(??{$a})\z/ ? '' : 'not '), | |
2933 | "ok $test - postponed interpolation of qr// preserves utf8\n"); | |
2934 | ++$test; | |
2935 | ||
ab01544f RGS |
2936 | print((length(qr/##/x) == 12 ? '' : 'not '), |
2937 | "ok $test - ## in qr// doesn't corrupt memory [perl #17776]\n"); | |
2938 | ++$test; | |
2939 | ||
cb50f42d YST |
2940 | { use re 'eval'; |
2941 | ||
2942 | print(("$x$x" =~ /^$x(??{$x})\z/ ? '' : 'not '), | |
2943 | "ok $test - postponed utf8 string in utf8 re matches utf8\n"); | |
2944 | ++$test; | |
2945 | ||
2946 | print(("$y$x" =~ /^$y(??{$x})\z/ ? '' : 'not '), | |
2947 | "ok $test - postponed utf8 string in non-utf8 re matches utf8\n"); | |
446eaa42 YST |
2948 | ++$test; |
2949 | ||
cb50f42d YST |
2950 | print(("$y$x" !~ /^$y(??{$y})\z/ ? '' : 'not '), |
2951 | "ok $test - postponed non-utf8 string in non-utf8 re doesn't match utf8\n"); | |
446eaa42 YST |
2952 | ++$test; |
2953 | ||
cb50f42d YST |
2954 | print(("$x$x" !~ /^$x(??{$y})\z/ ? '' : 'not '), |
2955 | "ok $test - postponed non-utf8 string in utf8 re doesn't match utf8\n"); | |
446eaa42 YST |
2956 | ++$test; |
2957 | ||
cb50f42d YST |
2958 | print(("$y$y" =~ /^$y(??{$y})\z/ ? '' : 'not '), |
2959 | "ok $test - postponed non-utf8 string in non-utf8 re matches non-utf8\n"); | |
2960 | ++$test; | |
2961 | ||
2962 | print(("$x$y" =~ /^$x(??{$y})\z/ ? '' : 'not '), | |
2963 | "ok $test - postponed non-utf8 string in utf8 re matches non-utf8\n"); | |
2964 | ++$test; | |
2965 | $y = $z; # reset $y after upgrade | |
2966 | ||
2967 | print(("$x$y" !~ /^$x(??{$x})\z/ ? '' : 'not '), | |
2968 | "ok $test - postponed utf8 string in utf8 re doesn't match non-utf8\n"); | |
2969 | ++$test; | |
2970 | $y = $z; # reset $y after upgrade | |
2971 | ||
2972 | print(("$y$y" !~ /^$y(??{$x})\z/ ? '' : 'not '), | |
2973 | "ok $test - postponed utf8 string in non-utf8 re doesn't match non-utf8\n"); | |
2974 | ++$test; | |
2975 | ||
2976 | } # no re 'eval' | |
2977 | ||
2d92f8a0 JH |
2978 | print "# more user-defined character properties\n"; |
2979 | ||
2980 | sub IsSyriac1 { | |
2981 | return <<'END'; | |
2982 | 0712 072C | |
2983 | 0730 074A | |
2984 | END | |
2985 | } | |
2986 | ||
2987 | print "\x{0712}" =~ /\p{IsSyriac1}/ ? "ok $test\n" : "not ok $test\n"; $test++; | |
2988 | print "\x{072F}" =~ /\P{IsSyriac1}/ ? "ok $test\n" : "not ok $test\n"; $test++; | |
2989 | ||
2990 | sub Syriac1 { | |
2991 | return <<'END'; | |
2992 | 0712 072C | |
2993 | 0730 074A | |
2994 | END | |
2995 | } | |
2996 | ||
2997 | print "\x{0712}" =~ /\p{Syriac1}/ ? "ok $test\n" : "not ok $test\n"; $test++; | |
2998 | print "\x{072F}" =~ /\P{Syriac1}/ ? "ok $test\n" : "not ok $test\n"; $test++; | |
2999 | ||
0e933229 | 3000 | { |
3a2263fe RGS |
3001 | print "# Change #18179\n"; |
3002 | # previously failed with "panic: end_shift | |
0e933229 IH |
3003 | my $s = "\x{100}" x 5; |
3004 | my $ok = $s =~ /(\x{100}{4})/; | |
3005 | my($ord, $len) = (ord $1, length $1); | |
3006 | print +($ok && $ord == 0x100 && $len == 4) | |
3007 | ? "ok $test\n" : "not ok $test\t# $ok/$ord/$len\n"; | |
3008 | ++$test; | |
3009 | } | |
3010 | ||
f14c76ed RGS |
3011 | { |
3012 | print "# [perl #15763]\n"; | |
3013 | ||
3014 | $a = "x\x{100}"; | |
3015 | chop $a; # but leaves the UTF-8 flag | |
3016 | $a .= "y"; # 1 byte before "y" | |
3017 | ||
3018 | ok($a =~ /^\C/, 'match one \C on 1-byte UTF-8'); | |
3019 | ok($a =~ /^\C{1}/, 'match \C{1}'); | |
3020 | ||
3021 | ok($a =~ /^\Cy/, 'match \Cy'); | |
3022 | ok($a =~ /^\C{1}y/, 'match \C{1}y'); | |
3023 | ||
3024 | $a = "\x{100}y"; # 2 bytes before "y" | |
3025 | ||
3026 | ok($a =~ /^\C/, 'match one \C on 2-byte UTF-8'); | |
3027 | ok($a =~ /^\C{1}/, 'match \C{1}'); | |
3028 | ok($a =~ /^\C\C/, 'match two \C'); | |
3029 | ok($a =~ /^\C{2}/, 'match \C{2}'); | |
3030 | ||
3031 | ok($a =~ /^\C\C\C/, 'match three \C on 2-byte UTF-8 and a byte'); | |
3032 | ok($a =~ /^\C{3}/, 'match \C{3}'); | |
3033 | ||
3034 | ok($a =~ /^\C\Cy/, 'match two \C'); | |
3035 | ok($a =~ /^\C{2}y/, 'match \C{2}'); | |
3036 | ||
836995da RGS |
3037 | ok($a !~ /^\C\C\Cy/, q{don't match three \Cy}); |
3038 | ok($a !~ /^\C{2}\Cy/, q{don't match \C{3}y}); | |
f14c76ed RGS |
3039 | |
3040 | $a = "\x{1000}y"; # 3 bytes before "y" | |
3041 | ||
3042 | ok($a =~ /^\C/, 'match one \C on three-byte UTF-8'); | |
3043 | ok($a =~ /^\C{1}/, 'match \C{1}'); | |
3044 | ok($a =~ /^\C\C/, 'match two \C'); | |
3045 | ok($a =~ /^\C{2}/, 'match \C{2}'); | |
3046 | ok($a =~ /^\C\C\C/, 'match three \C'); | |
3047 | ok($a =~ /^\C{3}/, 'match \C{3}'); | |
3048 | ||
3049 | ok($a =~ /^\C\C\C\C/, 'match four \C on three-byte UTF-8 and a byte'); | |
3050 | ok($a =~ /^\C{4}/, 'match \C{4}'); | |
3051 | ||
3052 | ok($a =~ /^\C\C\Cy/, 'match three \Cy'); | |
3053 | ok($a =~ /^\C{3}y/, 'match \C{3}y'); | |
3054 | ||
836995da RGS |
3055 | ok($a !~ /^\C\C\C\C\y/, q{don't match four \Cy}); |
3056 | ok($a !~ /^\C{4}y/, q{don't match \C{4}y}); | |
f14c76ed RGS |
3057 | } |
3058 | ||
5dec093f AE |
3059 | $_ = 'aaaaaaaaaa'; |
3060 | utf8::upgrade($_); chop $_; $\="\n"; | |
3061 | ok(/[^\s]+/, "m/[^\s]/ utf8"); | |
3062 | ok(/[^\d]+/, "m/[^\d]/ utf8"); | |
3063 | ok(($a = $_, $_ =~ s/[^\s]+/./g), "s/[^\s]/ utf8"); | |
3064 | ok(($a = $_, $a =~ s/[^\d]+/./g), "s/[^\s]/ utf8"); | |
f14c76ed | 3065 | |
ce97f9d6 JH |
3066 | ok("\x{100}" =~ /\x{100}/, "[perl #15397]"); |
3067 | ok("\x{100}" =~ /(\x{100})/, "[perl #15397]"); | |
3068 | ok("\x{100}" =~ /(\x{100}){1}/, "[perl #15397]"); | |
3069 | ok("\x{100}\x{100}" =~ /(\x{100}){2}/, "[perl #15397]"); | |
3070 | ok("\x{100}\x{100}" =~ /(\x{100})(\x{100})/, "[perl #15397]"); | |
3071 | ||
fbeb8e69 JH |
3072 | $x = "CD"; |
3073 | $x =~ /(AB)*?CD/; | |
3074 | ok(!defined $1, "[perl #7471]"); | |
ce97f9d6 | 3075 | |
fbeb8e69 JH |
3076 | $x = "CD"; |
3077 | $x =~ /(AB)*CD/; | |
3078 | ok(!defined $1, "[perl #7471]"); | |
3079 | ||
ec391688 JH |
3080 | $pattern = "^(b+?|a){1,2}c"; |
3081 | ok("bac" =~ /$pattern/ && $1 eq 'a', "[perl #3547]"); | |
3082 | ok("bbac" =~ /$pattern/ && $1 eq 'a', "[perl #3547]"); | |
3083 | ok("bbbac" =~ /$pattern/ && $1 eq 'a', "[perl #3547]"); | |
3084 | ok("bbbbac" =~ /$pattern/ && $1 eq 'a', "[perl #3547]"); | |
3085 | ||
a30b2f1f RGS |
3086 | { |
3087 | # [perl #18232] | |
3088 | "\x{100}" =~ /(.)/; | |
3089 | ok( $1 eq "\x{100}", '$1 is utf-8 [perl #18232]' ); | |
3090 | { 'a' =~ /./; } | |
3091 | ok( $1 eq "\x{100}", '$1 is still utf-8' ); | |
3092 | ok( $1 ne "\xC4\x80", '$1 is not non-utf-8' ); | |
3093 | } | |
3094 | ||
f119b0fb JH |
3095 | { |
3096 | use utf8; | |
3097 | my $attr = 'Name-1' ; | |
3098 | ||
3099 | my $NormalChar = qr/[\p{IsDigit}\p{IsLower}\p{IsUpper}]/; | |
3100 | my $NormalWord = qr/${NormalChar}+?/; | |
3101 | my $PredNameHyphen = qr/^${NormalWord}(\-${NormalWord})*?$/; | |
3102 | ||
3103 | $attr =~ /^$/; | |
3104 | ok( $attr =~ $PredNameHyphen, "[perl #19767] original test" ); | |
3105 | } | |
3106 | ||
3107 | { | |
3108 | use utf8; | |
3109 | "a" =~ m/[b]/; | |
3110 | ok ( "0" =~ /\p{N}+\z/, "[perl #19767] variant test" ); | |
3111 | } | |
3112 | ||
faf82a0b AE |
3113 | { |
3114 | ||
3115 | $p = 1; | |
3116 | foreach (1,2,3,4) { | |
3117 | $p++ if /(??{ $p })/ | |
3118 | } | |
3119 | ok ($p == 5, "[perl #20683] (??{ }) returns stale values"); | |
3120 | { package P; $a=1; sub TIESCALAR { bless[] } sub FETCH { $a++ } } | |
3121 | tie $p, P; | |
3122 | foreach (1,2,3,4) { | |
3123 | /(??{ $p })/ | |
3124 | } | |
3125 | ok ( $p == 5, "(??{ }) returns stale values"); | |
3126 | } | |
3127 | ||
351208f1 JH |
3128 | { |
3129 | # Subject: Odd regexp behavior | |
3130 | # From: Markus Kuhn <Markus.Kuhn@cl.cam.ac.uk> | |
3131 | # Date: Wed, 26 Feb 2003 16:53:12 +0000 | |
3132 | # Message-Id: <E18o4nw-0008Ly-00@wisbech.cl.cam.ac.uk> | |
3133 | # To: perl-unicode@perl.org | |
3134 | ||
3135 | $x = "\x{2019}\nk"; $x =~ s/(\S)\n(\S)/$1 $2/sg; | |
3136 | ok($x eq "\x{2019} k", "Markus Kuhn 2003-02-26"); | |
3137 | ||
3138 | $x = "b\nk"; $x =~ s/(\S)\n(\S)/$1 $2/sg; | |
3139 | ok($x eq "b k", "Markus Kuhn 2003-02-26"); | |
3140 | ||
3141 | ok("\x{2019}" =~ /\S/, "Markus Kuhn 2003-02-26"); | |
3142 | } | |
3143 | ||
91e09a61 AE |
3144 | { |
3145 | my $i; | |
3146 | ok('-1-3-5-' eq join('', split /((??{$i++}))/, '-1-3-5-'), | |
080c2dec AE |
3147 | "[perl #21411] (??{ .. }) corrupts split's stack"); |
3148 | split /(?{'WOW'})/, 'abc'; | |
3149 | ok('a|b|c' eq join ('|', @_), | |
3150 | "[perl #21411] (?{ .. }) version of the above"); | |
3151 | } | |
3152 | ||
3153 | { | |
3154 | split /(?{ split "" })/, "abc"; | |
3155 | ok(1,'cache_re & "(?{": it dumps core in 5.6.1 & 5.8.0'); | |
91e09a61 AE |
3156 | } |
3157 | ||
c517dc2b JH |
3158 | { |
3159 | ok("\x{100}\n" =~ /\x{100}\n$/, "UTF8 length cache and fbm_compile"); | |
3160 | } | |
ec391688 | 3161 | |
16e1b944 JH |
3162 | { |
3163 | package Str; | |
3164 | use overload q/""/ => sub { ${$_[0]}; }; | |
3165 | sub new { my ($c, $v) = @_; bless \$v, $c; } | |
3166 | ||
3167 | package main; | |
3168 | $_ = Str->new("a\x{100}/\x{100}b"); | |
3169 | ok(join(":", /\b(.)\x{100}/g) eq "a:/", "re_intuit_start and PL_bostr"); | |
3170 | } | |
3171 | ||
7ef91622 IH |
3172 | { |
3173 | $_ = "code: 'x' { '...' }\n"; study; | |
3174 | my @x; push @x, $& while m/'[^\']*'/gx; | |
3175 | ok(join(":", @x) eq "'x':'...'", | |
3176 | "[perl #17757] Parse::RecDescent triggers infinite loop"); | |
3177 | } | |
3178 | ||
14ebb1a2 JH |
3179 | { |
3180 | my $re = qq/^([^X]*)X/; | |
3181 | utf8::upgrade($re); | |
3182 | ok("\x{100}X" =~ /$re/, "S_cl_and ANYOF_UNICODE & ANYOF_INVERTED"); | |
3183 | } | |
3184 | ||
f02c194e RGS |
3185 | # bug #22354 |
3186 | sub func ($) { | |
3187 | ok( "a\nb" !~ /^b/, $_[0] ); | |
3188 | ok( "a\nb" =~ /^b/m, "$_[0] - with /m" ); | |
3189 | } | |
3190 | func "standalone"; | |
3191 | $_ = "x"; s/x/func "in subst"/e; | |
3192 | $_ = "x"; s/x/func "in multiline subst"/em; | |
3193 | #$_ = "x"; /x(?{func "in regexp"})/; | |
3194 | #$_ = "x"; /x(?{func "in multiline regexp"})/m; | |
3195 | ||
5aca4364 AG |
3196 | # bug #19049 |
3197 | $_="abcdef\n"; | |
3198 | @x = m/./g; | |
3199 | ok("abcde" eq "$`", '# TODO #19049 - global match not setting $`'); | |
3200 | ||
6b43b216 DM |
3201 | ok("123\x{100}" =~ /^.*1.*23\x{100}$/, 'uft8 + multiple floating substr'); |
3202 | ||
89d0f8e1 | 3203 | # LATIN SMALL/CAPITAL LETTER A WITH MACRON |
c1e0e3d2 NIS |
3204 | ok(" \x{101}" =~ qr/\x{100}/i, |
3205 | "<20030808193656.5109.1@llama.ni-s.u-net.com>"); | |
3206 | ||
89d0f8e1 | 3207 | # LATIN SMALL/CAPITAL LETTER A WITH RING BELOW |
5dab1207 NIS |
3208 | ok(" \x{1E01}" =~ qr/\x{1E00}/i, |
3209 | "<20030808193656.5109.1@llama.ni-s.u-net.com>"); | |
3210 | ||
89d0f8e1 JH |
3211 | # DESERET SMALL/CAPITAL LETTER LONG I |
3212 | ok(" \x{10428}" =~ qr/\x{10400}/i, | |
3213 | "<20030808193656.5109.1@llama.ni-s.u-net.com>"); | |
3214 | ||
3215 | # LATIN SMALL/CAPITAL LETTER A WITH RING BELOW + 'X' | |
3216 | ok(" \x{1E01}x" =~ qr/\x{1E00}X/i, | |
3217 | "<20030808193656.5109.1@llama.ni-s.u-net.com>"); | |
3218 | ||
a7913593 JH |
3219 | { |
3220 | # [perl #23769] Unicode regex broken on simple example | |
3221 | # regrepeat() didn't handle UTF-8 EXACT case right. | |
3222 | ||
3223 | my $s = "\x{a0}\x{a0}\x{a0}\x{100}"; chop $s; | |
3224 | ||
3225 | ok($s =~ /\x{a0}/, "[perl #23769]"); | |
3226 | ok($s =~ /\x{a0}+/, "[perl #23769]"); | |
3227 | ok($s =~ /\x{a0}\x{a0}/, "[perl #23769]"); | |
090f7165 JH |
3228 | |
3229 | ok("aaa\x{100}" =~ /(a+)/, "[perl #23769] easy invariant"); | |
3230 | ok($1 eq "aaa", "[perl #23769]"); | |
3231 | ||
3232 | ok("\xa0\xa0\xa0\x{100}" =~ /(\xa0+)/, "[perl #23769] regrepeat invariant"); | |
3233 | ok($1 eq "\xa0\xa0\xa0", "[perl #23769]"); | |
3234 | ||
3235 | ok("ababab\x{100} " =~ /((?:ab)+)/, "[perl #23769] hard invariant"); | |
3236 | ok($1 eq "ababab", "[perl #23769]"); | |
3237 | ||
3238 | ok("\xa0\xa1\xa0\xa1\xa0\xa1\x{100}" =~ /((?:\xa0\xa1)+)/, "[perl #23769] hard variant"); | |
3239 | ok($1 eq "\xa0\xa1\xa0\xa1\xa0\xa1", "[perl #23769]"); | |
3240 | ||
3241 | ok("aaa\x{100} " =~ /(a+?)/, "[perl #23769] easy invariant"); | |
3242 | ok($1 eq "a", "[perl #23769]"); | |
3243 | ||
3244 | ok("\xa0\xa0\xa0\x{100} " =~ /(\xa0+?)/, "[perl #23769] regrepeat variant"); | |
3245 | ok($1 eq "\xa0", "[perl #23769]"); | |
3246 | ||
3247 | ok("ababab\x{100} " =~ /((?:ab)+?)/, "[perl #23769] hard invariant"); | |
3248 | ok($1 eq "ab", "[perl #23769]"); | |
3249 | ||
3250 | ok("\xa0\xa1\xa0\xa1\xa0\xa1\x{100}" =~ /((?:\xa0\xa1)+?)/, "[perl #23769] hard variant"); | |
3251 | ok($1 eq "\xa0\xa1", "[perl #23769]"); | |
3252 | ||
3253 | ok("\xc4\xc4\xc4" !~ /(\x{100}+)/, "[perl #23769] don't match first byte of utf8 representation"); | |
3254 | ok("\xc4\xc4\xc4" !~ /(\x{100}+?)/, "[perl #23769] don't match first byte of utf8 representation"); | |
a7913593 JH |
3255 | } |
3256 | ||
4be7a33f HS |
3257 | for (120 .. 130) { |
3258 | my $head = 'x' x $_; | |
3259 | for my $tail ('\x{0061}', '\x{1234}') { | |
3260 | ok( | |
3261 | eval qq{ "$head$tail" =~ /$head$tail/ }, | |
3262 | '\x{...} misparsed in regexp near 127 char EXACT limit' | |
3263 | ); | |
3264 | } | |
3265 | } | |
3266 | ||
289555fe HS |
3267 | # perl #25269: panic: pp_match start/end pointers |
3268 | ok("a-bc" eq eval { | |
3269 | my($x, $y) = "bca" =~ /^(?=.*(a)).*(bc)/; | |
3270 | "$x-$y"; | |
3271 | }, 'captures can move backwards in string'); | |
3272 | ||
b6d5fef8 RGS |
3273 | # perl #27940: \cA not recognized in character classes |
3274 | ok("a\cAb" =~ /\cA/, '\cA in pattern'); | |
3275 | ok("a\cAb" =~ /[\cA]/, '\cA in character class'); | |
3276 | ok("a\cAb" =~ /[\cA-\cB]/, '\cA in character class range'); | |
3277 | ok("abc" =~ /[^\cA-\cB]/, '\cA in negated character class range'); | |
3278 | ok("a\cBb" =~ /[\cA-\cC]/, '\cB in character class range'); | |
3279 | ok("a\cCbc" =~ /[^\cA-\cB]/, '\cC in negated character class range'); | |
3280 | ok("a\cAb" =~ /(??{"\cA"})/, '\cA in ??{} pattern'); | |
5dab1207 | 3281 | |
0e788c72 HS |
3282 | # perl #28532: optional zero-width match at end of string is ignored |
3283 | ok(("abc" =~ /^abc(\z)?/) && defined($1), | |
3284 | 'optional zero-width match at end of string'); | |
3285 | ok(("abc" =~ /^abc(\z)??/) && !defined($1), | |
3286 | 'optional zero-width match at end of string'); | |
3287 | ||
3288 | # last test 1065 |