This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Naughty?
[perl5.git] / t / op / pat.t
CommitLineData
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
JH		 8
9print "1..615\n";
8d37f932 10
e4d48cc9
GS		 11BEGIN {
12 chdir 't' if -d 't';
20822f61 13 @INC = '../lib';
e4d48cc9 14}
ffbc6a93
JH		 15
16use re 'asciirange'; # Compute ranges in ASCII space
17
8d37f932 18eval 'use Config'; # Defaults assumed if this fails
8d063cd8
LW		 19
20$x = "abc\ndef\n";
21
22if ($x =~ /^abc/) {print "ok 1\n";} else {print "not ok 1\n";}
23if ($x !~ /^def/) {print "ok 2\n";} else {print "not ok 2\n";}
24
25$* = 1;
26if ($x =~ /^def/) {print "ok 3\n";} else {print "not ok 3\n";}
27$* = 0;
28
29$_ = '123';
30if (/^([0-9][0-9]*)/) {print "ok 4\n";} else {print "not ok 4\n";}
31
32if ($x =~ /^xxx/) {print "not ok 5\n";} else {print "ok 5\n";}
33if ($x !~ /^abc/) {print "not ok 6\n";} else {print "ok 6\n";}
34
35if ($x =~ /def/) {print "ok 7\n";} else {print "not ok 7\n";}
36if ($x !~ /def/) {print "not ok 8\n";} else {print "ok 8\n";}
37
38if ($x !~ /.def/) {print "ok 9\n";} else {print "not ok 9\n";}
39if ($x =~ /.def/) {print "not ok 10\n";} else {print "ok 10\n";}
40
41if ($x =~ /\ndef/) {print "ok 11\n";} else {print "not ok 11\n";}
42if ($x !~ /\ndef/) {print "not ok 12\n";} else {print "ok 12\n";}
43
44$_ = 'aaabbbccc';
45if (/(a*b*)(c*)/ && $1 eq 'aaabbb' && $2 eq 'ccc') {
46 print "ok 13\n";
47} else {
48 print "not ok 13\n";
49}
50if (/(a+b+c+)/ && $1 eq 'aaabbbccc') {
51 print "ok 14\n";
52} else {
53 print "not ok 14\n";
54}
55
56if (/a+b?c+/) {print "not ok 15\n";} else {print "ok 15\n";}
57
58$_ = 'aaabccc';
59if (/a+b?c+/) {print "ok 16\n";} else {print "not ok 16\n";}
60if (/a*b+c*/) {print "ok 17\n";} else {print "not ok 17\n";}
61
62$_ = 'aaaccc';
63if (/a*b?c*/) {print "ok 18\n";} else {print "not ok 18\n";}
64if (/a*b+c*/) {print "not ok 19\n";} else {print "ok 19\n";}
65
66$_ = 'abcdef';
67if (/bcd|xyz/) {print "ok 20\n";} else {print "not ok 20\n";}
68if (/xyz|bcd/) {print "ok 21\n";} else {print "not ok 21\n";}
69
70if (m|bc/*d|) {print "ok 22\n";} else {print "not ok 22\n";}
378cc40b
LW		 71
72if (/^$_$/) {print "ok 23\n";} else {print "not ok 23\n";}
73
74$* = 1; # test 3 only tested the optimized version--this one is for real
75if ("ab\ncd\n" =~ /^cd/) {print "ok 24\n";} else {print "not ok 24\n";}
76$* = 0;
77
cb55de95
JH		 78$XXX{123} = 123;
79$XXX{234} = 234;
80$XXX{345} = 345;
81
82@XXX = ('ok 25','not ok 25', 'ok 26','not ok 26','not ok 27');
83while ($_ = shift(@XXX)) {
84 ?(.*)? && (print $1,"\n");
85 /not/ && reset;
86 /not ok 26/ && reset 'X';
87}
88
89while (($key,$val) = each(%XXX)) {
90 print "not ok 27\n";
91 exit;
92}
93
94print "ok 27\n";
378cc40b 95
378cc40b
LW		 96'cde' =~ /[^ab]*/;
97'xyz' =~ //;
98if ($& eq 'xyz') {print "ok 28\n";} else {print "not ok 28\n";}
99
100$foo = '[^ab]*';
101'cde' =~ /$foo/;
102'xyz' =~ //;
103if ($& eq 'xyz') {print "ok 29\n";} else {print "not ok 29\n";}
104
105$foo = '[^ab]*';
106'cde' =~ /$foo/;
107'xyz' =~ /$null/;
108if ($& eq 'xyz') {print "ok 30\n";} else {print "not ok 30\n";}
a687059c
LW		 109
110$_ = 'abcdefghi';
111/def/; # optimized up to cmd
112if ("$`:$&:$'" eq 'abc:def:ghi') {print "ok 31\n";} else {print "not ok 31\n";}
113
114/cde/ + 0; # optimized only to spat
115if ("$`:$&:$'" eq 'ab:cde:fghi') {print "ok 32\n";} else {print "not ok 32\n";}
116
117/[d][e][f]/; # not optimized
118if ("$`:$&:$'" eq 'abc:def:ghi') {print "ok 33\n";} else {print "not ok 33\n";}
119
120$_ = 'now is the {time for all} good men to come to.';
121/ {([^}]*)}/;
122if ($1 eq 'time for all') {print "ok 34\n";} else {print "not ok 34 $1\n";}
123
124$_ = 'xxx {3,4} yyy zzz';
125print /( {3,4})/ ? "ok 35\n" : "not ok 35\n";
126print $1 eq ' ' ? "ok 36\n" : "not ok 36\n";
127print /( {4,})/ ? "not ok 37\n" : "ok 37\n";
128print /( {2,3}.)/ ? "ok 38\n" : "not ok 38\n";
129print $1 eq ' y' ? "ok 39\n" : "not ok 39\n";
130print /(y{2,3}.)/ ? "ok 40\n" : "not ok 40\n";
131print $1 eq 'yyy ' ? "ok 41\n" : "not ok 41\n";
132print /x {3,4}/ ? "not ok 42\n" : "ok 42\n";
133print /^xxx {3,4}/ ? "not ok 43\n" : "ok 43\n";
352d5a3a
LW		 134
135$_ = "now is the time for all good men to come to.";
136@words = /(\w+)/g;
137print join(':',@words) eq "now:is:the:time:for:all:good:men:to:come:to"
138 ? "ok 44\n"
139 : "not ok 44\n";
140
141@words = ();
142while (/\w+/g) {
143 push(@words, $&);
144}
145print join(':',@words) eq "now:is:the:time:for:all:good:men:to:come:to"
146 ? "ok 45\n"
147 : "not ok 45\n";
148
149@words = ();
71be2cbc 150pos = 0;
352d5a3a
LW		 151while (/to/g) {
152 push(@words, $&);
153}
154print join(':',@words) eq "to:to"
155 ? "ok 46\n"
71be2cbc 156 : "not ok 46 `@words'\n";
352d5a3a 157
71be2cbc 158pos $_ = 0;
352d5a3a
LW		 159@words = /to/g;
160print join(':',@words) eq "to:to"
161 ? "ok 47\n"
71be2cbc 162 : "not ok 47 `@words'\n";
352d5a3a
LW		 163
164$_ = "abcdefghi";
165
166$pat1 = 'def';
167$pat2 = '^def';
168$pat3 = '.def.';
169$pat4 = 'abc';
170$pat5 = '^abc';
171$pat6 = 'abc$';
172$pat7 = 'ghi';
173$pat8 = '\w*ghi';
174$pat9 = 'ghi$';
175
176$t1=$t2=$t3=$t4=$t5=$t6=$t7=$t8=$t9=0;
177
178for $iter (1..5) {
179 $t1++ if /$pat1/o;
180 $t2++ if /$pat2/o;
181 $t3++ if /$pat3/o;
182 $t4++ if /$pat4/o;
183 $t5++ if /$pat5/o;
184 $t6++ if /$pat6/o;
185 $t7++ if /$pat7/o;
186 $t8++ if /$pat8/o;
187 $t9++ if /$pat9/o;
188}
189
190$x = "$t1$t2$t3$t4$t5$t6$t7$t8$t9";
191print $x eq '505550555' ? "ok 48\n" : "not ok 48 $x\n";
1462b684
LW		 192
193$xyz = 'xyz';
194print "abc" =~ /^abc$|$xyz/ ? "ok 49\n" : "not ok 49\n";
195
196# perl 4.009 says "unmatched ()"
197eval '"abc" =~ /a(bc$)|$xyz/; $result = "$&:$1"';
198print $@ eq "" ? "ok 50\n" : "not ok 50\n";
199print $result eq "abc:bc" ? "ok 51\n" : "not ok 51\n";
a0d0e21e
LW		 200
201
202$_="abcfooabcbar";
203$x=/abc/g;
204print $` eq "" ? "ok 52\n" : "not ok 52\n" if $x;
205$x=/abc/g;
206print $` eq "abcfoo" ? "ok 53\n" : "not ok 53\n" if $x;
207$x=/abc/g;
208print $x == 0 ? "ok 54\n" : "not ok 54\n";
71be2cbc 209pos = 0;
a0d0e21e
LW		 210$x=/ABC/gi;
211print $` eq "" ? "ok 55\n" : "not ok 55\n" if $x;
212$x=/ABC/gi;
213print $` eq "abcfoo" ? "ok 56\n" : "not ok 56\n" if $x;
214$x=/ABC/gi;
215print $x == 0 ? "ok 57\n" : "not ok 57\n";
71be2cbc 216pos = 0;
a0d0e21e
LW		 217$x=/abc/g;
218print $' eq "fooabcbar" ? "ok 58\n" : "not ok 58\n" if $x;
219$x=/abc/g;
220print $' eq "bar" ? "ok 59\n" : "not ok 59\n" if $x;
221$_ .= '';
222@x=/abc/g;
223print scalar @x == 2 ? "ok 60\n" : "not ok 60\n";
71be2cbc 224
225$_ = "abdc";
226pos $_ = 2;
c90c0ff4 227/\Gc/gc;
71be2cbc 228print "not " if (pos $_) != 2;
229print "ok 61\n";
c90c0ff4 230/\Gc/g;
231print "not " if defined pos $_;
232print "ok 62\n";
c277df42
IZ		 233
234$out = 1;
235'abc' =~ m'a(?{ $out = 2 })b';
236print "not " if $out != 2;
237print "ok 63\n";
238
239$out = 1;
240'abc' =~ m'a(?{ $out = 3 })c';
241print "not " if $out != 1;
242print "ok 64\n";
243
244$_ = 'foobar1 bar2 foobar3 barfoobar5 foobar6';
245@out = /(?<!foo)bar./g;
246print "not " if "@out" ne 'bar2 barf';
247print "ok 65\n";
248
8d37f932
DD		 249# Tests which depend on REG_INFTY
250$reg_infty = defined $Config{reg_infty} ? $Config{reg_infty} : 32767;
251$reg_infty_m = $reg_infty - 1; $reg_infty_p = $reg_infty + 1;
252
253# As well as failing if the pattern matches do unexpected things, the
254# next three tests will fail if you should have picked up a lower-than-
255# default value for $reg_infty from Config.pm, but have not.
256
257undef $@;
258print "not " if eval q(('aaa' =~ /(a{1,$reg_infty_m})/)[0] ne 'aaa') || $@;
259print "ok 66\n";
260
261undef $@;
262print "not " if eval q(('a' x $reg_infty_m) !~ /a{$reg_infty_m}/) || $@;
263print "ok 67\n";
264
265undef $@;
266print "not " if eval q(('a' x ($reg_infty_m - 1)) =~ /a{$reg_infty_m}/) || $@;
267print "ok 68\n";
268
269undef $@;
270eval "'aaa' =~ /a{1,$reg_infty}/";
9baa0206 271print "not " if $@ !~ m%^\QQuantifier in {,} bigger than%;
8d37f932
DD		 272print "ok 69\n";
273
274eval "'aaa' =~ /a{1,$reg_infty_p}/";
275print "not "
9baa0206 276 if $@ !~ m%^\QQuantifier in {,} bigger than%;
8d37f932
DD		 277print "ok 70\n";
278undef $@;
279
280# Poke a couple more parse failures
281
282$context = 'x' x 256;
283eval qq("${context}y" =~ /(?<=$context)y/);
9baa0206 284print "not " if $@ !~ m%^\QLookbehind longer than 255 not%;
8d37f932
DD		 285print "ok 71\n";
286
b8c5462f 287# removed test
8d37f932
DD		 288print "ok 72\n";
289
c277df42 290# Long Monsters
8d37f932 291$test = 73;
c277df42
IZ		 292for $l (125, 140, 250, 270, 300000, 30) { # Ordered to free memory
293 $a = 'a' x $l;
294 print "# length=$l\nnot " unless "ba$a=" =~ /a$a=/;
295 print "ok $test\n";
296 $test++;
73d6d589 297
c277df42
IZ		 298 print "not " if "b$a=" =~ /a$a=/;
299 print "ok $test\n";
300 $test++;
301}
302
303# 20000 nodes, each taking 3 words per string, and 1 per branch
304$long_constant_len = join '|', 12120 .. 32645;
305$long_var_len = join '|', 8120 .. 28645;
306%ans = ( 'ax13876y25677lbc' => 1,
307 'ax13876y25677mcb' => 0, # not b.
308 'ax13876y35677nbc' => 0, # Num too big
309 'ax13876y25677y21378obc' => 1,
310 'ax13876y25677y21378zbc' => 0, # Not followed by [k-o]
311 'ax13876y25677y21378y21378kbc' => 1,
312 'ax13876y25677y21378y21378kcb' => 0, # Not b.
313 'ax13876y25677y21378y21378y21378kbc' => 0, # 5 runs
314 );
315
316for ( keys %ans ) {
73d6d589 317 print "# const-len `$_' not => $ans{$_}\nnot "
c277df42
IZ		 318 if $ans{$_} xor /a(?=([yx]($long_constant_len)){2,4}[k-o]).*b./o;
319 print "ok $test\n";
320 $test++;
73d6d589 321 print "# var-len `$_' not => $ans{$_}\nnot "
c277df42
IZ		 322 if $ans{$_} xor /a(?=([yx]($long_var_len)){2,4}[k-o]).*b./o;
323 print "ok $test\n";
324 $test++;
325}
326
327$_ = " a (bla()) and x(y b((l)u((e))) and b(l(e)e)e";
328$expect = "(bla()) ((l)u((e))) (l(e)e)";
329
73d6d589 330sub matchit {
cc6b7395 331 m/
c277df42 332 (
73d6d589 333 \(
c277df42
IZ		 334 (?{ $c = 1 }) # Initialize
335 (?:
336 (?(?{ $c == 0 }) # PREVIOUS iteration was OK, stop the loop
337 (?!
338 ) # Fail: will unwind one iteration back
73d6d589 339 )
c277df42
IZ		 340 (?:
341 [^()]+ # Match a big chunk
342 (?=
343 [()]
344 ) # Do not try to match subchunks
345 |
73d6d589 346 \(
c277df42
IZ		 347 (?{ ++$c })
348 |
73d6d589 349 \)
c277df42
IZ		 350 (?{ --$c })
351 )
352 )+ # This may not match with different subblocks
353 )
354 (?(?{ $c != 0 })
355 (?!
356 ) # Fail
357 ) # Otherwise the chunk 1 may succeed with $c>0
cc6b7395 358 /xg;
c277df42
IZ		 359}
360
0f5d15d6 361@ans = ();
c277df42
IZ		 362push @ans, $res while $res = matchit;
363
364print "# ans='@ans'\n# expect='$expect'\nnot " if "@ans" ne "1 1 1";
365print "ok $test\n";
366$test++;
367
368@ans = matchit;
369
370print "# ans='@ans'\n# expect='$expect'\nnot " if "@ans" ne $expect;
371print "ok $test\n";
372$test++;
373
96776eda
GS		 374print "not " unless "abc" =~ /^(??{"a"})b/;
375print "ok $test\n";
376$test++;
377
0f5d15d6 378my $matched;
14455d6c 379$matched = qr/\((?:(?>[^()]+)|(??{$matched}))*\)/;
0f5d15d6
IZ		 380
381@ans = @ans1 = ();
382push(@ans, $res), push(@ans1, $&) while $res = m/$matched/g;
383
384print "# ans='@ans'\n# expect='$expect'\nnot " if "@ans" ne "1 1 1";
385print "ok $test\n";
386$test++;
387
388print "# ans1='@ans1'\n# expect='$expect'\nnot " if "@ans1" ne $expect;
389print "ok $test\n";
390$test++;
391
392@ans = m/$matched/g;
393
394print "# ans='@ans'\n# expect='$expect'\nnot " if "@ans" ne $expect;
395print "ok $test\n";
396$test++;
397
c277df42
IZ		 398@ans = ('a/b' =~ m%(.*/)?(.*)%); # Stack may be bad
399print "not " if "@ans" ne 'a/ b';
400print "ok $test\n";
401$test++;
402
cc6b7395 403$code = '{$blah = 45}';
c277df42 404$blah = 12;
2cd61cdb
IZ		 405eval { /(?$code)/ };
406print "not " unless $@ and $@ =~ /not allowed at runtime/ and $blah == 12;
e4d48cc9
GS		 407print "ok $test\n";
408$test++;
409
2cd61cdb
IZ		 410for $code ('{$blah = 45}','=xx') {
411 $blah = 12;
412 $res = eval { "xx" =~ /(?$code)/o };
413 if ($code eq '=xx') {
414 print "#'$@','$res','$blah'\nnot " unless not $@ and $res;
415 } else {
73d6d589 416 print "#'$@','$res','$blah'\nnot " unless $@ and $@ =~ /not allowed at runtime/ and $blah == 12;
2cd61cdb
IZ		 417 }
418 print "ok $test\n";
419 $test++;
420}
421
e4d48cc9
GS		 422$code = '{$blah = 45}';
423$blah = 12;
424eval "/(?$code)/";
cc6b7395
IZ		 425print "not " if $blah != 45;
426print "ok $test\n";
427$test++;
428
429$blah = 12;
430/(?{$blah = 45})/;
c277df42
IZ		 431print "not " if $blah != 45;
432print "ok $test\n";
433$test++;
434
74d6a13a
MB		 435$x = 'banana';
436$x =~ /.a/g;
437print "not " unless pos($x) == 2;
438print "ok $test\n";
439$test++;
440
441$x =~ /.z/gc;
442print "not " unless pos($x) == 2;
443print "ok $test\n";
444$test++;
445
446sub f {
447 my $p = $_[0];
448 return $p;
449}
450
451$x =~ /.a/g;
452print "not " unless f(pos($x)) == 4;
453print "ok $test\n";
454$test++;
4599a1de 455
ce862d02
IZ		 456$x = $^R = 67;
457'foot' =~ /foo(?{$x = 12; 75})[t]/;
458print "not " unless $^R eq '75';
459print "ok $test\n";
460$test++;
461
462$x = $^R = 67;
463'foot' =~ /foo(?{$x = 12; 75})[xy]/;
464print "not " unless $^R eq '67' and $x eq '12';
465print "ok $test\n";
466$test++;
467
468$x = $^R = 67;
469'foot' =~ /foo(?{ $^R + 12 })((?{ $x = 12; $^R + 17 })[xy])?/;
470print "not " unless $^R eq '79' and $x eq '12';
471print "ok $test\n";
472$test++;
473
8782bef2
GB		 474print "not " unless qr/\b\v$/i eq '(?i-xsm:\bv$)';
475print "ok $test\n";
476$test++;
477
478print "not " unless qr/\b\v$/s eq '(?s-xim:\bv$)';
479print "ok $test\n";
480$test++;
481
482print "not " unless qr/\b\v$/m eq '(?m-xis:\bv$)';
483print "ok $test\n";
484$test++;
485
486print "not " unless qr/\b\v$/x eq '(?x-ism:\bv$)';
487print "ok $test\n";
488$test++;
489
490print "not " unless qr/\b\v$/xism eq '(?msix:\bv$)';
491print "ok $test\n";
492$test++;
493
494print "not " unless qr/\b\v$/ eq '(?-xism:\bv$)';
97197631
IZ		 495print "ok $test\n";
496$test++;
497
7e5428c5
IZ		 498$_ = 'xabcx';
499foreach $ans ('', 'c') {
500 /(?<=(?=a)..)((?=c)|.)/g;
02db2b7b 501 print "# \$1 ='$1'\n# \$ans='$ans'\nnot " unless $1 eq $ans;
7e5428c5
IZ		 502 print "ok $test\n";
503 $test++;
504}
505
506$_ = 'a';
507foreach $ans ('', 'a', '') {
508 /^|a|$/g;
02db2b7b 509 print "# \$& ='$&'\n# \$ans='$ans'\nnot " unless $& eq $ans;
7e5428c5
IZ		 510 print "ok $test\n";
511 $test++;
512}
513
09f25ae4 514sub prefixify {
73d6d589
NIS		 515 my($v,$a,$b,$res) = @_;
516 $v =~ s/\Q$a\E/$b/;
517 print "not " unless $res eq $v;
09f25ae4
IZ		 518 print "ok $test\n";
519 $test++;
520}
521prefixify('/a/b/lib/arch', "/a/b/lib", 'X/lib', 'X/lib/arch');
522prefixify('/a/b/man/arch', "/a/b/man", 'X/man', 'X/man/arch');
523
524$_ = 'var="foo"';
525/(\")/;
526print "not " unless $1 and /$1/;
527print "ok $test\n";
528$test++;
529
73d6d589 530$a=qr/(?{++$b})/;
2cd61cdb 531$b = 7;
73d6d589
NIS		 532/$a$a/;
533print "not " unless $b eq '9';
2cd61cdb
IZ		 534print "ok $test\n";
535$test++;
536
73d6d589
NIS		 537$c="$a";
538/$a$a/;
539print "not " unless $b eq '11';
2cd61cdb
IZ		 540print "ok $test\n";
541$test++;
542
543{
73d6d589
NIS		 544 use re "eval";
545 /$a$c$a/;
546 print "not " unless $b eq '14';
2cd61cdb
IZ		 547 print "ok $test\n";
548 $test++;
549
160cb429
JH		 550 local $lex_a = 2;
551 my $lex_a = 43;
552 my $lex_b = 17;
553 my $lex_c = 27;
554 my $lex_res = ($lex_b =~ qr/$lex_b(?{ $lex_c = $lex_a++ })/);
555 print "not " unless $lex_res eq '1';
556 print "ok $test\n";
557 $test++;
558 print "not " unless $lex_a eq '44';
559 print "ok $test\n";
560 $test++;
561 print "not " unless $lex_c eq '43';
562 print "ok $test\n";
563 $test++;
564
565
73d6d589 566 no re "eval";
2cd61cdb 567 $match = eval { /$a$c$a/ };
73d6d589 568 print "not "
2cd61cdb
IZ		 569 unless $b eq '14' and $@ =~ /Eval-group not allowed/ and not $match;
570 print "ok $test\n";
571 $test++;
572}
cbce877f
IZ		 573
574{
160cb429
JH		 575 local $lex_a = 2;
576 my $lex_a = 43;
577 my $lex_b = 17;
578 my $lex_c = 27;
579 my $lex_res = ($lex_b =~ qr/17(?{ $lex_c = $lex_a++ })/);
580 print "not " unless $lex_res eq '1';
581 print "ok $test\n";
582 $test++;
583 print "not " unless $lex_a eq '44';
584 print "ok $test\n";
585 $test++;
586 print "not " unless $lex_c eq '43';
587 print "ok $test\n";
588 $test++;
589}
590
591{
cbce877f
IZ		 592 package aa;
593 $c = 2;
594 $::c = 3;
595 '' =~ /(?{ $c = 4 })/;
596 print "not " unless $c == 4;
597}
598print "ok $test\n";
599$test++;
600print "not " unless $c == 3;
601print "ok $test\n";
73d6d589
NIS		 602$test++;
603
4599a1de
JH		 604sub must_warn_pat {
605 my $warn_pat = shift;
606 return sub { print "not " unless $_[0] =~ /$warn_pat/ }
607}
608
609sub must_warn {
610 my ($warn_pat, $code) = @_;
9f1b1f2d
GS		 611 local %SIG;
612 eval 'BEGIN { use warnings; $SIG{__WARN__} = $warn_pat };' . $code;
4599a1de
JH		 613 print "ok $test\n";
614 $test++;
615}
616
617
618sub make_must_warn {
619 my $warn_pat = shift;
620 return sub { must_warn(must_warn_pat($warn_pat)) }
621}
622
623my $for_future = make_must_warn('reserved for future extensions');
624
625&$for_future('q(a:[b]:) =~ /[x[:foo:]]/');
9baa0206
HS		 626
627#&$for_future('q(a=[b]=) =~ /[x[=foo=]]/');
628print "ok $test\n"; $test++; # now a fatal croak
629
630#&$for_future('q(a.[b].) =~ /[x[.foo.]]/');
631print "ok $test\n"; $test++; # now a fatal croak
f7e33566
GS		 632
633# test if failure of patterns returns empty list
634$_ = 'aaa';
635@_ = /bbb/;
636print "not " if @_;
637print "ok $test\n";
638$test++;
639
640@_ = /bbb/g;
641print "not " if @_;
642print "ok $test\n";
643$test++;
644
645@_ = /(bbb)/;
646print "not " if @_;
647print "ok $test\n";
648$test++;
649
650@_ = /(bbb)/g;
651print "not " if @_;
652print "ok $test\n";
653$test++;
654
6cef1e77
IZ		 655/a(?=.$)/;
656print "not " if $#+ != 0 or $#- != 0;
657print "ok $test\n";
658$test++;
659
660print "not " if $+[0] != 2 or $-[0] != 1;
661print "ok $test\n";
662$test++;
663
73d6d589 664print "not "
6cef1e77
IZ		 665 if defined $+[1] or defined $-[1] or defined $+[2] or defined $-[2];
666print "ok $test\n";
667$test++;
668
669/a(a)(a)/;
670print "not " if $#+ != 2 or $#- != 2;
671print "ok $test\n";
672$test++;
673
674print "not " if $+[0] != 3 or $-[0] != 0;
675print "ok $test\n";
676$test++;
677
678print "not " if $+[1] != 2 or $-[1] != 1;
679print "ok $test\n";
680$test++;
681
682print "not " if $+[2] != 3 or $-[2] != 2;
683print "ok $test\n";
684$test++;
685
73d6d589 686print "not "
6cef1e77
IZ		 687 if defined $+[3] or defined $-[3] or defined $+[4] or defined $-[4];
688print "ok $test\n";
689$test++;
690
691/.(a)(b)?(a)/;
692print "not " if $#+ != 3 or $#- != 3;
693print "ok $test\n";
694$test++;
695
696print "not " if $+[0] != 3 or $-[0] != 0;
697print "ok $test\n";
698$test++;
699
700print "not " if $+[1] != 2 or $-[1] != 1;
701print "ok $test\n";
702$test++;
703
704print "not " if $+[3] != 3 or $-[3] != 2;
705print "ok $test\n";
706$test++;
707
73d6d589 708print "not "
6cef1e77
IZ		 709 if defined $+[2] or defined $-[2] or defined $+[4] or defined $-[4];
710print "ok $test\n";
711$test++;
712
713/.(a)/;
714print "not " if $#+ != 1 or $#- != 1;
715print "ok $test\n";
716$test++;
717
718print "not " if $+[0] != 2 or $-[0] != 0;
719print "ok $test\n";
720$test++;
721
722print "not " if $+[1] != 2 or $-[1] != 1;
723print "ok $test\n";
724$test++;
725
73d6d589 726print "not "
6cef1e77
IZ		 727 if defined $+[2] or defined $-[2] or defined $+[3] or defined $-[3];
728print "ok $test\n";
729$test++;
730
03a27ae7 731eval { $+[0] = 13; };
73d6d589 732print "not "
03a27ae7
MG		 733 if $@ !~ /^Modification of a read-only value attempted/;
734print "ok $test\n";
735$test++;
736
737eval { $-[0] = 13; };
73d6d589 738print "not "
03a27ae7
MG		 739 if $@ !~ /^Modification of a read-only value attempted/;
740print "ok $test\n";
741$test++;
742
743eval { @+ = (7, 6, 5); };
73d6d589 744print "not "
03a27ae7
MG		 745 if $@ !~ /^Modification of a read-only value attempted/;
746print "ok $test\n";
747$test++;
748
749eval { @- = qw(foo bar); };
73d6d589 750print "not "
03a27ae7
MG		 751 if $@ !~ /^Modification of a read-only value attempted/;
752print "ok $test\n";
753$test++;
754
8f580fb8
IZ		 755/.(a)(ba*)?/;
756print "#$#-..$#+\nnot " if $#+ != 2 or $#- != 1;
757print "ok $test\n";
758$test++;
759
ad94a511
IZ		 760$_ = 'aaa';
761pos = 1;
762@a = /\Ga/g;
763print "not " unless "@a" eq "a a";
764print "ok $test\n";
765$test++;
766
22e551b9
IZ		 767$str = 'abcde';
768pos $str = 2;
769
770print "not " if $str =~ /^\G/;
771print "ok $test\n";
772$test++;
773
774print "not " if $str =~ /^.\G/;
775print "ok $test\n";
776$test++;
777
778print "not " unless $str =~ /^..\G/;
779print "ok $test\n";
780$test++;
781
782print "not " if $str =~ /^...\G/;
783print "ok $test\n";
784$test++;
785
786print "not " unless $str =~ /.\G./ and $& eq 'bc';
787print "ok $test\n";
788$test++;
789
790print "not " unless $str =~ /\G../ and $& eq 'cd';
791print "ok $test\n";
792$test++;
793
9661b544
IZ		 794undef $foo; undef $bar;
795print "#'$str','$foo','$bar'\nnot "
73d6d589 796 unless $str =~ /b(?{$foo = $_; $bar = pos})c/
9661b544
IZ		 797 and $foo eq 'abcde' and $bar eq 2;
798print "ok $test\n";
799$test++;
800
801undef $foo; undef $bar;
802pos $str = undef;
803print "#'$str','$foo','$bar'\nnot "
73d6d589 804 unless $str =~ /b(?{$foo = $_; $bar = pos})c/g
9661b544
IZ		 805 and $foo eq 'abcde' and $bar eq 2 and pos $str eq 3;
806print "ok $test\n";
807$test++;
808
809$_ = $str;
810
811undef $foo; undef $bar;
812print "#'$str','$foo','$bar'\nnot "
73d6d589 813 unless /b(?{$foo = $_; $bar = pos})c/
9661b544
IZ		 814 and $foo eq 'abcde' and $bar eq 2;
815print "ok $test\n";
816$test++;
817
818undef $foo; undef $bar;
819print "#'$str','$foo','$bar'\nnot "
73d6d589 820 unless /b(?{$foo = $_; $bar = pos})c/g
9661b544
IZ		 821 and $foo eq 'abcde' and $bar eq 2 and pos eq 3;
822print "ok $test\n";
823$test++;
824
825undef $foo; undef $bar;
826pos = undef;
8271 while /b(?{$foo = $_; $bar = pos})c/g;
828print "#'$str','$foo','$bar'\nnot "
829 unless $foo eq 'abcde' and $bar eq 2 and not defined pos;
830print "ok $test\n";
831$test++;
832
833undef $foo; undef $bar;
834$_ = 'abcde|abcde';
835print "#'$str','$foo','$bar','$_'\nnot "
73d6d589 836 unless s/b(?{$foo = $_; $bar = pos})c/x/g and $foo eq 'abcde|abcde'
9661b544
IZ		 837 and $bar eq 8 and $_ eq 'axde|axde';
838print "ok $test\n";
839$test++;
840
5c5e4c24
IZ		 841@res = ();
842# List context:
843$_ = 'abcde|abcde';
844@dummy = /([ace]).(?{push @res, $1,$2})([ce])(?{push @res, $1,$2})/g;
845@res = map {defined $_ ? "'$_'" : 'undef'} @res;
846$res = "@res";
847print "#'@res' '$_'\nnot "
848 unless "@res" eq "'a' undef 'a' 'c' 'e' undef 'a' undef 'a' 'c'";
849print "ok $test\n";
850$test++;
851
852@res = ();
853@dummy = /([ace]).(?{push @res, $`,$&,$'})([ce])(?{push @res, $`,$&,$'})/g;
854@res = map {defined $_ ? "'$_'" : 'undef'} @res;
855$res = "@res";
856print "#'@res' '$_'\nnot "
857 unless "@res" eq
858 "'' 'ab' 'cde|abcde' " .
859 "'' 'abc' 'de|abcde' " .
860 "'abcd' 'e|' 'abcde' " .
861 "'abcde|' 'ab' 'cde' " .
862 "'abcde|' 'abc' 'de'" ;
863print "ok $test\n";
864$test++;
865
b7a35066
IZ		 866#Some more \G anchor checks
867$foo='aabbccddeeffgg';
868
869pos($foo)=1;
870
871$foo=~/.\G(..)/g;
872print "not " unless($1 eq 'ab');
873print "ok $test\n";
874$test++;
875
876pos($foo) += 1;
877$foo=~/.\G(..)/g;
878print "not " unless($1 eq 'cc');
879print "ok $test\n";
880$test++;
881
882pos($foo) += 1;
883$foo=~/.\G(..)/g;
884print "not " unless($1 eq 'de');
885print "ok $test\n";
886$test++;
887
0ef3e39e
HS		 888print "not " unless $foo =~ /\Gef/g;
889print "ok $test\n";
890$test++;
891
b7a35066
IZ		 892undef pos $foo;
893
894$foo=~/\G(..)/g;
895print "not " unless($1 eq 'aa');
896print "ok $test\n";
897$test++;
898
899$foo=~/\G(..)/g;
900print "not " unless($1 eq 'bb');
901print "ok $test\n";
902$test++;
903
904pos($foo)=5;
905$foo=~/\G(..)/g;
906print "not " unless($1 eq 'cd');
907print "ok $test\n";
908$test++;
909
73d6d589 910$_='123x123';
e60df1fa
IZ		 911@res = /(\d*|x)/g;
912print "not " unless('123||x|123|' eq join '|', @res);
913print "ok $test\n";
914$test++;
915
9d080a66
GS		 916# see if matching against temporaries (created via pp_helem()) is safe
917{ foo => "ok $test\n".$^X }->{foo} =~ /^(.*)\n/g;
918print "$1\n";
919$test++;
920
cf93c79d
IZ		 921# See if $i work inside (?{}) in the presense of saved substrings and
922# changing $_
923@a = qw(foo bar);
924@b = ();
925s/(\w)(?{push @b, $1})/,$1,/g for @a;
926
927print "# \@b='@b', expect 'f o o b a r'\nnot " unless("@b" eq "f o o b a r");
928print "ok $test\n";
929$test++;
930
931print "not " unless("@a" eq ",f,,o,,o, ,b,,a,,r,");
932print "ok $test\n";
933$test++;
934
2c914db6 935$brackets = qr{
14455d6c 936 { (?> [^{}]+ | (??{ $brackets }) )* }
2c914db6
IZ		 937 }x;
938
939"{{}" =~ $brackets;
940print "ok $test\n"; # Did we survive?
941$test++;
942
943"something { long { and } hairy" =~ $brackets;
944print "ok $test\n"; # Did we survive?
945$test++;
946
14455d6c 947"something { long { and } hairy" =~ m/((??{ $brackets }))/;
2c914db6
IZ		 948print "not " unless $1 eq "{ and }";
949print "ok $test\n";
950$test++;
951
30944b6d
IZ		 952$_ = "a-a\nxbb";
953pos=1;
954m/^-.*bb/mg and print "not ";
955print "ok $test\n";
956$test++;
30382c73
IZ		 957
958$text = "aaXbXcc";
959pos($text)=0;
960$text =~ /\GXb*X/g and print 'not ';
961print "ok $test\n";
962$test++;
3cf5c195
IZ		 963
964$text = "xA\n" x 500;
965$text =~ /^\s*A/m and print 'not ';
966print "ok $test\n";
967$test++;
d506a20d
IZ		 968
969$text = "abc dbf";
970@res = ($text =~ /.*?(b).*?\b/g);
971"@res" eq 'b b' or print 'not ';
972print "ok $test\n";
973$test++;
974
9442cb0e 975@a = map chr,0..255;
aeaf5620
GS		 976
977@b = grep(/\S/,@a);
978@c = grep(/[^\s]/,@a);
979print "not " if "@b" ne "@c";
9442cb0e
GS		 980print "ok $test\n";
981$test++;
982
aeaf5620
GS		 983@b = grep(/\S/,@a);
984@c = grep(/[\S]/,@a);
985print "not " if "@b" ne "@c";
9442cb0e
GS		 986print "ok $test\n";
987$test++;
988
aeaf5620
GS		 989@b = grep(/\s/,@a);
990@c = grep(/[^\S]/,@a);
991print "not " if "@b" ne "@c";
9442cb0e
GS		 992print "ok $test\n";
993$test++;
994
aeaf5620
GS		 995@b = grep(/\s/,@a);
996@c = grep(/[\s]/,@a);
997print "not " if "@b" ne "@c";
9442cb0e
GS		 998print "ok $test\n";
999$test++;
1000
aeaf5620
GS		 1001@b = grep(/\D/,@a);
1002@c = grep(/[^\d]/,@a);
1003print "not " if "@b" ne "@c";
9442cb0e
GS		 1004print "ok $test\n";
1005$test++;
1006
aeaf5620
GS		 1007@b = grep(/\D/,@a);
1008@c = grep(/[\D]/,@a);
1009print "not " if "@b" ne "@c";
9442cb0e
GS		 1010print "ok $test\n";
1011$test++;
1012
aeaf5620
GS		 1013@b = grep(/\d/,@a);
1014@c = grep(/[^\D]/,@a);
1015print "not " if "@b" ne "@c";
9442cb0e
GS		 1016print "ok $test\n";
1017$test++;
1018
aeaf5620
GS		 1019@b = grep(/\d/,@a);
1020@c = grep(/[\d]/,@a);
1021print "not " if "@b" ne "@c";
9442cb0e
GS		 1022print "ok $test\n";
1023$test++;
1024
aeaf5620
GS		 1025@b = grep(/\W/,@a);
1026@c = grep(/[^\w]/,@a);
1027print "not " if "@b" ne "@c";
9442cb0e
GS		 1028print "ok $test\n";
1029$test++;
1030
aeaf5620
GS		 1031@b = grep(/\W/,@a);
1032@c = grep(/[\W]/,@a);
1033print "not " if "@b" ne "@c";
9442cb0e
GS		 1034print "ok $test\n";
1035$test++;
1036
aeaf5620
GS		 1037@b = grep(/\w/,@a);
1038@c = grep(/[^\W]/,@a);
1039print "not " if "@b" ne "@c";
9442cb0e
GS		 1040print "ok $test\n";
1041$test++;
1042
aeaf5620
GS		 1043@b = grep(/\w/,@a);
1044@c = grep(/[\w]/,@a);
1045print "not " if "@b" ne "@c";
9442cb0e
GS		 1046print "ok $test\n";
1047$test++;
1aeab75a
GS		 1048
1049# see if backtracking optimization works correctly
1050"\n\n" =~ /\n $ \n/x or print "not ";
1051print "ok $test\n";
1052$test++;
1053
1054"\n\n" =~ /\n* $ \n/x or print "not ";
1055print "ok $test\n";
1056$test++;
1057
1058"\n\n" =~ /\n+ $ \n/x or print "not ";
1059print "ok $test\n";
1060$test++;
05b4157f
GS		 1061
1062[] =~ /^ARRAY/ or print "# [] \nnot ";
1063print "ok $test\n";
1064$test++;
1065
1066eval << 'EOE';
1067{
1068 package S;
1069 use overload '""' => sub { 'Object S' };
1070 sub new { bless [] }
1071}
1072$a = 'S'->new;
1073EOE
1074
1075$a and $a =~ /^Object\sS/ or print "# '$a' \nnot ";
1076print "ok $test\n";
1077$test++;
815d35b9
MG		 1078
1079# test result of match used as match (!)
1080'a1b' =~ ('xyz' =~ /y/) and $` eq 'a' or print "not ";
1081print "ok $test\n";
1082$test++;
1083
1084'a1b' =~ ('xyz' =~ /t/) and $` eq 'a' or print "not ";
1085print "ok $test\n";
1086$test++;
5e39e1e5
HS		 1087
1088$w = 0;
1089{
1090 local $SIG{__WARN__} = sub { $w = 1 };
1091 local $^W = 1;
1092 $w = 1 if ("1\n" x 102) =~ /^\s*\n/m;
1093}
1094print $w ? "not " : "", "ok $test\n";
1095$test++;
aaa51d5e
JF		 1096
1097my %space = ( spc => " ",
1098 tab => "\t",
1099 cr => "\r",
1100 lf => "\n",
1101 ff => "\f",
75369ccb
JH		 1102# There's no \v but the vertical tabulator seems miraculously
1103# be 11 both in ASCII and EBCDIC.
aaa51d5e
JF		 1104 vt => chr(11),
1105 false => "space" );
1106
1107my @space0 = sort grep { $space{$_} =~ /\s/ } keys %space;
1108my @space1 = sort grep { $space{$_} =~ /[[:space:]]/ } keys %space;
1109my @space2 = sort grep { $space{$_} =~ /[[:blank:]]/ } keys %space;
1110
1111print "not " unless "@space0" eq "cr ff lf spc tab";
3bec3564 1112print "ok $test # @space0\n";
aaa51d5e
JF		 1113$test++;
1114
1115print "not " unless "@space1" eq "cr ff lf spc tab vt";
3bec3564 1116print "ok $test # @space1\n";
aaa51d5e
JF		 1117$test++;
1118
1119print "not " unless "@space2" eq "spc tab";
3bec3564 1120print "ok $test # @space2\n";
aaa51d5e 1121$test++;
73d6d589 1122
a1933d95
HS		 1123# bugid 20001021.005 - this caused a SEGV
1124print "not " unless undef =~ /^([^\/]*)(.*)$/;
1125print "ok $test\n";
1126$test++;
b91bb191
JH		 1127
1128# bugid 20000731.001
1129
1130print "not " unless "A \x{263a} B z C" =~ /A . B (??{ "z" }) C/;
1131print "ok $test\n";
1132$test++;
1133
3baa4c62
JH		 1134$_ = "a\x{100}b";
1135if (/(.)(\C)(\C)(.)/) {
1136 print "ok 232\n";
1137 if ($1 eq "a") {
1138 print "ok 233\n";
1139 } else {
1140 print "not ok 233\n";
1141 }
1142 if ($2 eq "\xC4") {
1143 print "ok 234\n";
1144 } else {
1145 print "not ok 234\n";
1146 }
1147 if ($3 eq "\x80") {
1148 print "ok 235\n";
1149 } else {
1150 print "not ok 235\n";
1151 }
1152 if ($4 eq "b") {
1153 print "ok 236\n";
1154 } else {
1155 print "not ok 236\n";
1156 }
1157} else {
1158 for (232..236) {
1159 print "not ok $_\n";
1160 }
1161}
1162$_ = "\x{100}";
1163if (/(\C)/g) {
1164 print "ok 237\n";
73d6d589 1165 # currently \C are still tagged as UTF-8
3baa4c62
JH		 1166 if ($1 eq "\xC4") {
1167 print "ok 238\n";
1168 } else {
1169 print "not ok 238\n";
1170 }
1171} else {
1172 for (237..238) {
1173 print "not ok $_\n";
1174 }
1175}
1176if (/(\C)/g) {
1177 print "ok 239\n";
73d6d589 1178 # currently \C are still tagged as UTF-8
3baa4c62
JH		 1179 if ($1 eq "\x80") {
1180 print "ok 240\n";
1181 } else {
1182 print "not ok 240\n";
1183 }
1184} else {
1185 for (239..240) {
1186 print "not ok $_\n";
1187 }
1188}
b485d051 1189
db615365
JP		 1190{
1191 # japhy -- added 03/03/2001
1192 () = (my $str = "abc") =~ /(...)/;
1193 $str = "def";
1194 print "not " if $1 ne "abc";
fd291da9
JH		 1195 print "ok 241\n";
1196}
1197
1198# The 242 and 243 go with the 244 and 245.
1199# The trick is that in EBCDIC the explicit numeric range should match
1200# (as also in non-EBCDIC) but the explicit alphabetic range should not match.
1201
1202if ("\x8e" =~ /[\x89-\x91]/) {
1203 print "ok 242\n";
1204} else {
1205 print "not ok 242\n";
1206}
1207
1208if ("\xce" =~ /[\xc9-\xd1]/) {
db615365 1209 print "ok 243\n";
fd291da9
JH		 1210} else {
1211 print "not ok 243\n";
1212}
1213
1214# In most places these tests would succeed since \x8e does not
1215# in most character sets match 'i' or 'j' nor would \xce match
1216# 'I' or 'J', but strictly speaking these tests are here for
1217# the good of EBCDIC, so let's test these only there.
1218if (ord('i') == 0x89 && ord('J') == 0xd1) { # EBCDIC
1219 if ("\x8e" !~ /[i-j]/) {
1220 print "ok 244\n";
1221 } else {
1222 print "not ok 244\n";
1223 }
1224 if ("\xce" !~ /[I-J]/) {
1225 print "ok 245\n";
1226 } else {
1227 print "not ok 245\n";
1228 }
1229} else {
1230 for (244..245) {
60425c38 1231 print "ok $_ # Skip: only in EBCDIC\n";
fd291da9 1232 }
db615365 1233}
4765795a
JH		 1234
1235print "not " unless "\x{ab}" =~ /\x{ab}/;
1236print "ok 246\n";
1237
1238print "not " unless "\x{abcd}" =~ /\x{abcd}/;
1239print "ok 247\n";
1240
1241{
1242 # bug id 20001008.001
1243
4765795a
JH		 1244 my $test = 248;
1245 my @x = ("stra\337e 138","stra\337e 138");
1246 for (@x) {
1247 s/(\d+)\s*([\w\-]+)/$1 . uc $2/e;
1248 my($latin) = /^(.+)(?:\s+\d)/;
1249 print $latin eq "stra\337e" ? "ok $test\n" : # 248,249
1250 "#latin[$latin]\nnot ok $test\n";
1251 $test++;
1252 $latin =~ s/stra\337e/straße/; # \303\237 after the 2nd a
1253 use utf8;
1254 $latin =~ s!(s)tr(?:aß|s+e)!$1tr.!; # \303\237 after the a
1255 }
1256}
1257
1258{
1259 print "not " unless "ba\xd4c" =~ /([a\xd4]+)/ && $1 eq "a\xd4";
1260 print "ok 250\n";
1261
1262 print "not " unless "ba\xd4c" =~ /([a\xd4]+)/ && $1 eq "a\x{d4}";
1263 print "ok 251\n";
1264
1265 print "not " unless "ba\x{d4}c" =~ /([a\xd4]+)/ && $1 eq "a\x{d4}";
1266 print "ok 252\n";
1267
1268 print "not " unless "ba\x{d4}c" =~ /([a\xd4]+)/ && $1 eq "a\xd4";
1269 print "ok 253\n";
1270
1271 print "not " unless "ba\xd4c" =~ /([a\x{d4}]+)/ && $1 eq "a\xd4";
1272 print "ok 254\n";
1273
1274 print "not " unless "ba\xd4c" =~ /([a\x{d4}]+)/ && $1 eq "a\x{d4}";
1275 print "ok 255\n";
1276
1277 print "not " unless "ba\x{d4}c" =~ /([a\x{d4}]+)/ && $1 eq "a\x{d4}";
1278 print "ok 256\n";
1279
1280 print "not " unless "ba\x{d4}c" =~ /([a\x{d4}]+)/ && $1 eq "a\xd4";
1281 print "ok 257\n";
1282}
1283
1284{
1285 # the first half of 20001028.003
1286
1287 my $X = chr(1448);
1288 my ($Y) = $X =~ /(.*)/;
1289 print "not " unless $Y eq v1448 && length($Y) == 1;
1290 print "ok 258\n";
1291}
1292
1293{
1294 # 20001108.001
1295
1296 my $X = "Szab\x{f3},Bal\x{e1}zs";
1297 my $Y = $X;
1298 $Y =~ s/(B)/$1/ for 0..3;
1299 print "not " unless $Y eq $X && $X eq "Szab\x{f3},Bal\x{e1}zs";
1300 print "ok 259\n";
1301}
1302
1303{
1304 # the second half of 20001028.003
1305
3568d838 1306 my $X = '';
4765795a
JH		 1307 $X =~ s/^/chr(1488)/e;
1308 print "not " unless length $X == 1 && ord($X) == 1488;
1309 print "ok 260\n";
1310}
1311
1312{
1313 # 20000517.001
1314
1315 my $x = "\x{100}A";
1316
1317 $x =~ s/A/B/;
1318
1319 print "not " unless $x eq "\x{100}B" && length($x) == 2;
1320 print "ok 261\n";
1321}
1322
1323{
1324 # bug id 20001230.002
1325
1326 print "not " unless "École" =~ /^\C\C(.)/ && $1 eq 'c';
1327 print "ok 262\n";
1328
1329 print "not " unless "École" =~ /^\C\C(c)/;
1330 print "ok 263\n";
1331}
1332
1333{
1334 my $test = 264; # till 575
1335
1336 use charnames ':full';
1337
1338 # This is far from complete testing, there are dozens of character
1339 # classes in Unicode. The mixing of literals and \N{...} is
1340 # intentional so that in non-Latin-1 places we test the native
1341 # characters, not the Unicode code points.
1342
1343 my %s = (
1344 "a" => 'Ll',
1345 "\N{CYRILLIC SMALL LETTER A}" => 'Ll',
1346 "A" => 'Lu',
1347 "\N{GREEK CAPITAL LETTER ALPHA}" => 'Lu',
1348 "\N{HIRAGANA LETTER SMALL A}" => 'Lo',
1349 "\N{COMBINING GRAVE ACCENT}" => 'Mn',
1350 "0" => 'Nd',
1351 "\N{ARABIC-INDIC DIGIT ZERO}" => 'Nd',
1352 "_" => 'N',
1353 "!" => 'P',
1354 " " => 'Zs',
1355 "\0" => 'Cc',
1356 );
73d6d589 1357
3568d838
JH		 1358 for my $char (map { s/^\S+ //; $_ }
1359 sort map { sprintf("%06x", ord($_))." $_" } keys %s) {
4765795a 1360 my $class = $s{$char};
3568d838
JH		 1361 my $code = sprintf("%06x", ord($char));
1362 printf "#\n# 0x$code\n#\n";
4765795a
JH		 1363 print "# IsAlpha\n";
1364 if ($class =~ /^[LM]/) {
1365 print "not " unless $char =~ /\p{IsAlpha}/;
1366 print "ok $test\n"; $test++;
1367 print "not " if $char =~ /\P{IsAlpha}/;
1368 print "ok $test\n"; $test++;
1369 } else {
1370 print "not " if $char =~ /\p{IsAlpha}/;
1371 print "ok $test\n"; $test++;
1372 print "not " unless $char =~ /\P{IsAlpha}/;
1373 print "ok $test\n"; $test++;
1374 }
1375 print "# IsAlnum\n";
1376 if ($class =~ /^[LMN]/ && $char ne "_") {
1377 print "not " unless $char =~ /\p{IsAlnum}/;
1378 print "ok $test\n"; $test++;
1379 print "not " if $char =~ /\P{IsAlnum}/;
1380 print "ok $test\n"; $test++;
1381 } else {
1382 print "not " if $char =~ /\p{IsAlnum}/;
1383 print "ok $test\n"; $test++;
1384 print "not " unless $char =~ /\P{IsAlnum}/;
1385 print "ok $test\n"; $test++;
1386 }
1387 print "# IsASCII\n";
3568d838 1388 if ($code le '00007f') {
4765795a
JH		 1389 print "not " unless $char =~ /\p{IsASCII}/;
1390 print "ok $test\n"; $test++;
1391 print "not " if $char =~ /\P{IsASCII}/;
1392 print "ok $test\n"; $test++;
1393 } else {
1394 print "not " if $char =~ /\p{IsASCII}/;
1395 print "ok $test\n"; $test++;
1396 print "not " unless $char =~ /\P{IsASCII}/;
1397 print "ok $test\n"; $test++;
1398 }
1399 print "# IsCntrl\n";
1400 if ($class =~ /^C/) {
1401 print "not " unless $char =~ /\p{IsCntrl}/;
1402 print "ok $test\n"; $test++;
1403 print "not " if $char =~ /\P{IsCntrl}/;
1404 print "ok $test\n"; $test++;
1405 } else {
1406 print "not " if $char =~ /\p{IsCntrl}/;
1407 print "ok $test\n"; $test++;
1408 print "not " unless $char =~ /\P{IsCntrl}/;
1409 print "ok $test\n"; $test++;
1410 }
1411 print "# IsBlank\n";
1412 if ($class =~ /^Z[lp]/ || $char eq " ") {
1413 print "not " unless $char =~ /\p{IsBlank}/;
1414 print "ok $test\n"; $test++;
1415 print "not " if $char =~ /\P{IsBlank}/;
1416 print "ok $test\n"; $test++;
1417 } else {
1418 print "not " if $char =~ /\p{IsBlank}/;
1419 print "ok $test\n"; $test++;
1420 print "not " unless $char =~ /\P{IsBlank}/;
1421 print "ok $test\n"; $test++;
1422 }
1423 print "# IsDigit\n";
1424 if ($class =~ /^Nd$/) {
1425 print "not " unless $char =~ /\p{IsDigit}/;
1426 print "ok $test\n"; $test++;
1427 print "not " if $char =~ /\P{IsDigit}/;
1428 print "ok $test\n"; $test++;
1429 } else {
1430 print "not " if $char =~ /\p{IsDigit}/;
1431 print "ok $test\n"; $test++;
1432 print "not " unless $char =~ /\P{IsDigit}/;
1433 print "ok $test\n"; $test++;
1434 }
1435 print "# IsGraph\n";
1436 if ($class =~ /^([LMNPS])|Co/) {
1437 print "not " unless $char =~ /\p{IsGraph}/;
1438 print "ok $test\n"; $test++;
1439 print "not " if $char =~ /\P{IsGraph}/;
1440 print "ok $test\n"; $test++;
1441 } else {
1442 print "not " if $char =~ /\p{IsGraph}/;
1443 print "ok $test\n"; $test++;
1444 print "not " unless $char =~ /\P{IsGraph}/;
1445 print "ok $test\n"; $test++;
1446 }
1447 print "# IsLower\n";
1448 if ($class =~ /^Ll$/) {
1449 print "not " unless $char =~ /\p{IsLower}/;
1450 print "ok $test\n"; $test++;
1451 print "not " if $char =~ /\P{IsLower}/;
1452 print "ok $test\n"; $test++;
1453 } else {
1454 print "not " if $char =~ /\p{IsLower}/;
1455 print "ok $test\n"; $test++;
1456 print "not " unless $char =~ /\P{IsLower}/;
1457 print "ok $test\n"; $test++;
1458 }
1459 print "# IsPrint\n";
1460 if ($class =~ /^([LMNPS])|Co|Zs/) {
1461 print "not " unless $char =~ /\p{IsPrint}/;
1462 print "ok $test\n"; $test++;
1463 print "not " if $char =~ /\P{IsPrint}/;
1464 print "ok $test\n"; $test++;
1465 } else {
1466 print "not " if $char =~ /\p{IsPrint}/;
1467 print "ok $test\n"; $test++;
1468 print "not " unless $char =~ /\P{IsPrint}/;
1469 print "ok $test\n"; $test++;
1470 }
1471 print "# IsPunct\n";
1472 if ($class =~ /^P/ || $char eq "_") {
1473 print "not " unless $char =~ /\p{IsPunct}/;
1474 print "ok $test\n"; $test++;
1475 print "not " if $char =~ /\P{IsPunct}/;
1476 print "ok $test\n"; $test++;
1477 } else {
1478 print "not " if $char =~ /\p{IsPunct}/;
1479 print "ok $test\n"; $test++;
1480 print "not " unless $char =~ /\P{IsPunct}/;
1481 print "ok $test\n"; $test++;
1482 }
1483 print "# IsSpace\n";
1484 if ($class =~ /^Z/ || ($code =~ /^(0009|000A|000B|000C|000D)$/)) {
1485 print "not " unless $char =~ /\p{IsSpace}/;
1486 print "ok $test\n"; $test++;
1487 print "not " if $char =~ /\P{IsSpace}/;
1488 print "ok $test\n"; $test++;
1489 } else {
1490 print "not " if $char =~ /\p{IsSpace}/;
1491 print "ok $test\n"; $test++;
1492 print "not " unless $char =~ /\P{IsSpace}/;
1493 print "ok $test\n"; $test++;
1494 }
1495 print "# IsUpper\n";
1496 if ($class =~ /^L[ut]/) {
1497 print "not " unless $char =~ /\p{IsUpper}/;
1498 print "ok $test\n"; $test++;
1499 print "not " if $char =~ /\P{IsUpper}/;
1500 print "ok $test\n"; $test++;
1501 } else {
1502 print "not " if $char =~ /\p{IsUpper}/;
1503 print "ok $test\n"; $test++;
1504 print "not " unless $char =~ /\P{IsUpper}/;
1505 print "ok $test\n"; $test++;
1506 }
1507 print "# IsWord\n";
1508 if ($class =~ /^[LMN]/ || $char eq "_") {
1509 print "not " unless $char =~ /\p{IsWord}/;
1510 print "ok $test\n"; $test++;
1511 print "not " if $char =~ /\P{IsWord}/;
1512 print "ok $test\n"; $test++;
1513 } else {
1514 print "not " if $char =~ /\p{IsWord}/;
1515 print "ok $test\n"; $test++;
1516 print "not " unless $char =~ /\P{IsWord}/;
1517 print "ok $test\n"; $test++;
1518 }
1519 }
1520}
1521
1522{
1523 $_ = "abc\x{100}\x{200}\x{300}\x{380}\x{400}defg";
1524
1525 if (/(.\x{300})./) {
1526 print "ok 576\n";
1527
1528 print "not " unless $` eq "abc\x{100}" && length($`) == 4;
73d6d589 1529 print "ok 577\n";
4765795a
JH		 1530
1531 print "not " unless $& eq "\x{200}\x{300}\x{380}" && length($&) == 3;
73d6d589 1532 print "ok 578\n";
4765795a
JH		 1533
1534 print "not " unless $' eq "\x{400}defg" && length($') == 5;
73d6d589 1535 print "ok 579\n";
4765795a
JH		 1536
1537 print "not " unless $1 eq "\x{200}\x{300}" && length($1) == 2;
73d6d589 1538 print "ok 580\n";
a8a2fe91
JH		 1539 } else {
1540 for (576..580) { print "not ok $_\n" }
4765795a
JH		 1541 }
1542}
8269fa76
JH		 1543
1544{
1545 # bug id 20010306.008
1546
1547 $a = "a\x{1234}";
1548 # The original bug report had 'no utf8' here but that was irrelevant.
1549 $a =~ m/\w/; # used to core dump
1550
1551 print "ok 581\n";
1552}
b8ef571c
JH		 1553
1554{
339e86bc
JH		 1555 $test = 582;
1556
b8ef571c
JH		 1557 # bugid 20010410.006
1558 for my $rx (
1559 '/(.*?)\{(.*?)\}/csg',
1560 '/(.*?)\{(.*?)\}/cg',
1561 '/(.*?)\{(.*?)\}/sg',
1562 '/(.*?)\{(.*?)\}/g',
1563 '/(.+?)\{(.+?)\}/csg',
1564 )
1565 {
1566 my($input, $i);
1567
1568 $i = 0;
1569 $input = "a{b}c{d}";
1570 eval <<EOT;
1571 while (eval \$input =~ $rx) {
1572 print "# \\\$1 = '\$1' \\\$2 = '\$2'\n";
1573 ++\$i;
1574 }
1575EOT
1576 print "not " unless $i == 2;
1577 print "ok " . $test++ . "\n";
1578 }
1579}
209a9bc1
JH		 1580
1581{
1582 # from Robin Houston
1583
1584 my $x = "\x{12345678}";
1585 $x =~ s/(.)/$1/g;
1586 print "not " unless ord($x) == 0x12345678 && length($x) == 1;
1587 print "ok 587\n";
1588}
3568d838
JH		 1589
1590{
1591 my $x = "\x7f";
1592
1593 print "not " if $x =~ /[\x80-\xff]/;
1594 print "ok 588\n";
1595
1596 print "not " if $x =~ /[\x80-\x{100}]/;
1597 print "ok 589\n";
1598
1599 print "not " if $x =~ /[\x{100}]/;
1600 print "ok 590\n";
1601
1602 print "not " if $x =~ /\p{InLatin1Supplement}/;
1603 print "ok 591\n";
1604
1605 print "not " unless $x =~ /\P{InLatin1Supplement}/;
1606 print "ok 592\n";
1607
1608 print "not " if $x =~ /\p{InLatinExtendedA}/;
1609 print "ok 593\n";
1610
1611 print "not " unless $x =~ /\P{InLatinExtendedA}/;
1612 print "ok 594\n";
1613}
1614
1615{
1616 my $x = "\x80";
1617
1618 print "not " unless $x =~ /[\x80-\xff]/;
1619 print "ok 595\n";
1620
1621 print "not " unless $x =~ /[\x80-\x{100}]/;
1622 print "ok 596\n";
1623
1624 print "not " if $x =~ /[\x{100}]/;
1625 print "ok 597\n";
1626
1627 print "not " unless $x =~ /\p{InLatin1Supplement}/;
1628 print "ok 598\n";
1629
1630 print "not " if $x =~ /\P{InLatin1Supplement}/;
1631 print "ok 599\n";
1632
1633 print "not " if $x =~ /\p{InLatinExtendedA}/;
1634 print "ok 600\n";
1635
1636 print "not " unless $x =~ /\P{InLatinExtendedA}/;
1637 print "ok 601\n";
1638}
1639
1640{
1641 my $x = "\xff";
1642
1643 print "not " unless $x =~ /[\x80-\xff]/;
1644 print "ok 602\n";
1645
1646 print "not " unless $x =~ /[\x80-\x{100}]/;
1647 print "ok 603\n";
1648
1649 print "not " if $x =~ /[\x{100}]/;
1650 print "ok 604\n";
1651
1652 print "not " unless $x =~ /\p{InLatin1Supplement}/;
1653 print "ok 605\n";
1654
1655 print "not " if $x =~ /\P{InLatin1Supplement}/;
1656 print "ok 606\n";
1657
1658 print "not " if $x =~ /\p{InLatinExtendedA}/;
1659 print "ok 607\n";
1660
1661 print "not " unless $x =~ /\P{InLatinExtendedA}/;
1662 print "ok 608\n";
1663}
1664
1665{
1666 my $x = "\x{100}";
1667
1668 print "not " if $x =~ /[\x80-\xff]/;
1669 print "ok 609\n";
1670
1671 print "not " unless $x =~ /[\x80-\x{100}]/;
1672 print "ok 610\n";
1673
1674 print "not " unless $x =~ /[\x{100}]/;
1675 print "ok 611\n";
1676
1677 print "not " if $x =~ /\p{InLatin1Supplement}/;
1678 print "ok 612\n";
1679
1680 print "not " unless $x =~ /\P{InLatin1Supplement}/;
1681 print "ok 613\n";
1682
1683 print "not " unless $x =~ /\p{InLatinExtendedA}/;
1684 print "ok 614\n";
1685
1686 print "not " if $x =~ /\P{InLatinExtendedA}/;
1687 print "ok 615\n";
1688}
1689
Unnamed repository; edit this file 'description' to name the repository.