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