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