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