1#!./perl 2# 3# This is a home for regular expression tests that don't fit into 4# the format supported by re/regexp.t. If you want to add a test 5# that does fit that format, add it to re/re_tests, not here. 6 7use strict; 8use warnings; 9use 5.010; 10 11sub run_tests; 12 13$| = 1; 14 15 16BEGIN { 17 chdir 't' if -d 't'; 18 @INC = ('../lib','.'); 19 require './test.pl'; 20} 21 22plan tests => 472; # Update this when adding/deleting tests. 23 24run_tests() unless caller; 25 26# 27# Tests start here. 28# 29sub run_tests { 30 31 { 32 my $x = "abc\ndef\n"; 33 (my $x_pretty = $x) =~ s/\n/\\n/g; 34 35 ok $x =~ /^abc/, qq ["$x_pretty" =~ /^abc/]; 36 ok $x !~ /^def/, qq ["$x_pretty" !~ /^def/]; 37 38 # used to be a test for $* 39 ok $x =~ /^def/m, qq ["$x_pretty" =~ /^def/m]; 40 41 ok(!($x =~ /^xxx/), qq ["$x_pretty" =~ /^xxx/]); 42 ok(!($x !~ /^abc/), qq ["$x_pretty" !~ /^abc/]); 43 44 ok $x =~ /def/, qq ["$x_pretty" =~ /def/]; 45 ok(!($x !~ /def/), qq ["$x_pretty" !~ /def/]); 46 47 ok $x !~ /.def/, qq ["$x_pretty" !~ /.def/]; 48 ok(!($x =~ /.def/), qq ["$x_pretty" =~ /.def/]); 49 50 ok $x =~ /\ndef/, qq ["$x_pretty" =~ /\\ndef/]; 51 ok(!($x !~ /\ndef/), qq ["$x_pretty" !~ /\\ndef/]); 52 } 53 54 { 55 $_ = '123'; 56 ok /^([0-9][0-9]*)/, qq [\$_ = '$_'; /^([0-9][0-9]*)/]; 57 } 58 59 { 60 $_ = 'aaabbbccc'; 61 ok /(a*b*)(c*)/ && $1 eq 'aaabbb' && $2 eq 'ccc', 62 qq [\$_ = '$_'; /(a*b*)(c*)/]; 63 ok /(a+b+c+)/ && $1 eq 'aaabbbccc', qq [\$_ = '$_'; /(a+b+c+)/]; 64 unlike($_, qr/a+b?c+/, qq [\$_ = '$_'; /a+b?c+/]); 65 66 $_ = 'aaabccc'; 67 ok /a+b?c+/, qq [\$_ = '$_'; /a+b?c+/]; 68 ok /a*b?c*/, qq [\$_ = '$_'; /a*b?c*/]; 69 70 $_ = 'aaaccc'; 71 ok /a*b?c*/, qq [\$_ = '$_'; /a*b?c*/]; 72 unlike($_, qr/a*b+c*/, qq [\$_ = '$_'; /a*b+c*/]); 73 74 $_ = 'abcdef'; 75 ok /bcd|xyz/, qq [\$_ = '$_'; /bcd|xyz/]; 76 ok /xyz|bcd/, qq [\$_ = '$_'; /xyz|bcd/]; 77 ok m|bc/*d|, qq [\$_ = '$_'; m|bc/*d|]; 78 ok /^$_$/, qq [\$_ = '$_'; /^\$_\$/]; 79 } 80 81 { 82 # used to be a test for $* 83 ok "ab\ncd\n" =~ /^cd/m, q ["ab\ncd\n" =~ /^cd/m]; 84 } 85 86 { 87 our %XXX = map {($_ => $_)} 123, 234, 345; 88 89 our @XXX = ('ok 1','not ok 1', 'ok 2','not ok 2','not ok 3'); 90 while ($_ = shift(@XXX)) { 91 my $e = index ($_, 'not') >= 0 ? '' : 1; 92 my $r = m?(.*)?; 93 is($r, $e, "?(.*)?"); 94 /not/ && reset; 95 if (/not ok 2/) { 96 if ($^O eq 'VMS') { 97 $_ = shift(@XXX); 98 } 99 else { 100 reset 'X'; 101 } 102 } 103 } 104 105 SKIP: { 106 if ($^O eq 'VMS') { 107 skip "Reset 'X'", 1; 108 } 109 ok !keys %XXX, "%XXX is empty"; 110 } 111 112 } 113 114 { 115 my $message = "Test empty pattern"; 116 my $xyz = 'xyz'; 117 my $cde = 'cde'; 118 119 $cde =~ /[^ab]*/; 120 $xyz =~ //; 121 is($&, $xyz, $message); 122 123 my $foo = '[^ab]*'; 124 $cde =~ /$foo/; 125 $xyz =~ //; 126 is($&, $xyz, $message); 127 128 $cde =~ /$foo/; 129 my $null; 130 no warnings 'uninitialized'; 131 $xyz =~ /$null/; 132 is($&, $xyz, $message); 133 134 $null = ""; 135 $xyz =~ /$null/; 136 is($&, $xyz, $message); 137 } 138 139 { 140 my $message = q !Check $`, $&, $'!; 141 $_ = 'abcdefghi'; 142 /def/; # optimized up to cmd 143 is("$`:$&:$'", 'abc:def:ghi', $message); 144 145 no warnings 'void'; 146 /cde/ + 0; # optimized only to spat 147 is("$`:$&:$'", 'ab:cde:fghi', $message); 148 149 /[d][e][f]/; # not optimized 150 is("$`:$&:$'", 'abc:def:ghi', $message); 151 } 152 153 { 154 $_ = 'now is the {time for all} good men to come to.'; 155 / {([^}]*)}/; 156 is($1, 'time for all', "Match braces"); 157 } 158 159 { 160 my $message = "{N,M} quantifier"; 161 $_ = 'xxx {3,4} yyy zzz'; 162 ok(/( {3,4})/, $message); 163 is($1, ' ', $message); 164 unlike($_, qr/( {4,})/, $message); 165 ok(/( {2,3}.)/, $message); 166 is($1, ' y', $message); 167 ok(/(y{2,3}.)/, $message); 168 is($1, 'yyy ', $message); 169 unlike($_, qr/x {3,4}/, $message); 170 unlike($_, qr/^xxx {3,4}/, $message); 171 } 172 173 { 174 my $message = "Test /g"; 175 local $" = ":"; 176 $_ = "now is the time for all good men to come to."; 177 my @words = /(\w+)/g; 178 my $exp = "now:is:the:time:for:all:good:men:to:come:to"; 179 180 is("@words", $exp, $message); 181 182 @words = (); 183 while (/\w+/g) { 184 push (@words, $&); 185 } 186 is("@words", $exp, $message); 187 188 @words = (); 189 pos = 0; 190 while (/to/g) { 191 push(@words, $&); 192 } 193 is("@words", "to:to", $message); 194 195 pos $_ = 0; 196 @words = /to/g; 197 is("@words", "to:to", $message); 198 } 199 200 { 201 $_ = "abcdefghi"; 202 203 my $pat1 = 'def'; 204 my $pat2 = '^def'; 205 my $pat3 = '.def.'; 206 my $pat4 = 'abc'; 207 my $pat5 = '^abc'; 208 my $pat6 = 'abc$'; 209 my $pat7 = 'ghi'; 210 my $pat8 = '\w*ghi'; 211 my $pat9 = 'ghi$'; 212 213 my $t1 = my $t2 = my $t3 = my $t4 = my $t5 = 214 my $t6 = my $t7 = my $t8 = my $t9 = 0; 215 216 for my $iter (1 .. 5) { 217 $t1++ if /$pat1/o; 218 $t2++ if /$pat2/o; 219 $t3++ if /$pat3/o; 220 $t4++ if /$pat4/o; 221 $t5++ if /$pat5/o; 222 $t6++ if /$pat6/o; 223 $t7++ if /$pat7/o; 224 $t8++ if /$pat8/o; 225 $t9++ if /$pat9/o; 226 } 227 my $x = "$t1$t2$t3$t4$t5$t6$t7$t8$t9"; 228 is($x, '505550555', "Test /o"); 229 } 230 231 { 232 my $xyz = 'xyz'; 233 ok "abc" =~ /^abc$|$xyz/, "| after \$"; 234 235 # perl 4.009 says "unmatched ()" 236 my $message = '$ inside ()'; 237 238 my $result; 239 eval '"abc" =~ /a(bc$)|$xyz/; $result = "$&:$1"'; 240 is($@, "", $message); 241 is($result, "abc:bc", $message); 242 } 243 244 { 245 my $message = "Scalar /g"; 246 $_ = "abcfooabcbar"; 247 248 ok( /abc/g && $` eq "", $message); 249 ok( /abc/g && $` eq "abcfoo", $message); 250 ok(!/abc/g, $message); 251 252 $message = "Scalar /gi"; 253 pos = 0; 254 ok( /ABC/gi && $` eq "", $message); 255 ok( /ABC/gi && $` eq "abcfoo", $message); 256 ok(!/ABC/gi, $message); 257 258 $message = "Scalar /g"; 259 pos = 0; 260 ok( /abc/g && $' eq "fooabcbar", $message); 261 ok( /abc/g && $' eq "bar", $message); 262 263 $_ .= ''; 264 my @x = /abc/g; 265 is(@x, 2, "/g reset after assignment"); 266 } 267 268 { 269 my $message = '/g, \G and pos'; 270 $_ = "abdc"; 271 pos $_ = 2; 272 /\Gc/gc; 273 is(pos $_, 2, $message); 274 /\Gc/g; 275 is(pos $_, undef, $message); 276 } 277 278 { 279 my $message = '(?{ })'; 280 our $out = 1; 281 'abc' =~ m'a(?{ $out = 2 })b'; 282 is($out, 2, $message); 283 284 $out = 1; 285 'abc' =~ m'a(?{ $out = 3 })c'; 286 is($out, 1, $message); 287 } 288 289 { 290 $_ = 'foobar1 bar2 foobar3 barfoobar5 foobar6'; 291 my @out = /(?<!foo)bar./g; 292 is("@out", 'bar2 barf', "Negative lookbehind"); 293 } 294 295 { 296 my $message = "REG_INFTY tests"; 297 # Tests which depend on REG_INFTY 298 299 # Defaults assumed if this fails 300 eval { require Config; }; 301 $::reg_infty = $Config::Config{reg_infty} // 32767; 302 $::reg_infty_m = $::reg_infty - 1; 303 $::reg_infty_p = $::reg_infty + 1; 304 $::reg_infty_m = $::reg_infty_m; # Suppress warning. 305 306 # As well as failing if the pattern matches do unexpected things, the 307 # next three tests will fail if you should have picked up a lower-than- 308 # default value for $reg_infty from Config.pm, but have not. 309 310 is(eval q{('aaa' =~ /(a{1,$::reg_infty_m})/)[0]}, 'aaa', $message); 311 is($@, '', $message); 312 is(eval q{('a' x $::reg_infty_m) =~ /a{$::reg_infty_m}/}, 1, $message); 313 is($@, '', $message); 314 isnt(q{('a' x ($::reg_infty_m - 1)) !~ /a{$::reg_infty_m}/}, 1, $message); 315 is($@, '', $message); 316 317 eval "'aaa' =~ /a{1,$::reg_infty}/"; 318 like($@, qr/^\QQuantifier in {,} bigger than/, $message); 319 eval "'aaa' =~ /a{1,$::reg_infty_p}/"; 320 like($@, qr/^\QQuantifier in {,} bigger than/, $message); 321 } 322 323 { 324 # Poke a couple more parse failures 325 my $context = 'x' x 256; 326 eval qq("${context}y" =~ /(?<=$context)y/); 327 ok $@ =~ /^\QLookbehind longer than 255 not/, "Lookbehind limit"; 328 } 329 330 { 331 # Long Monsters 332 for my $l (125, 140, 250, 270, 300000, 30) { # Ordered to free memory 333 my $a = 'a' x $l; 334 my $message = "Long monster, length = $l"; 335 like("ba$a=", qr/a$a=/, $message); 336 unlike("b$a=", qr/a$a=/, $message); 337 like("b$a=", qr/ba+=/, $message); 338 339 like("ba$a=", qr/b(?:a|b)+=/, $message); 340 } 341 } 342 343 { 344 # 20000 nodes, each taking 3 words per string, and 1 per branch 345 my $long_constant_len = join '|', 12120 .. 32645; 346 my $long_var_len = join '|', 8120 .. 28645; 347 my %ans = ( 'ax13876y25677lbc' => 1, 348 'ax13876y25677mcb' => 0, # not b. 349 'ax13876y35677nbc' => 0, # Num too big 350 'ax13876y25677y21378obc' => 1, 351 'ax13876y25677y21378zbc' => 0, # Not followed by [k-o] 352 'ax13876y25677y21378y21378kbc' => 1, 353 'ax13876y25677y21378y21378kcb' => 0, # Not b. 354 'ax13876y25677y21378y21378y21378kbc' => 0, # 5 runs 355 ); 356 357 for (keys %ans) { 358 my $message = "20000 nodes, const-len '$_'"; 359 ok !($ans{$_} xor /a(?=([yx]($long_constant_len)){2,4}[k-o]).*b./o), $message; 360 361 $message = "20000 nodes, var-len '$_'"; 362 ok !($ans{$_} xor /a(?=([yx]($long_var_len)){2,4}[k-o]).*b./o,), $message; 363 } 364 } 365 366 { 367 my $message = "Complicated backtracking"; 368 $_ = " a (bla()) and x(y b((l)u((e))) and b(l(e)e)e"; 369 my $expect = "(bla()) ((l)u((e))) (l(e)e)"; 370 371 use vars '$c'; 372 sub matchit { 373 m/ 374 ( 375 \( 376 (?{ $c = 1 }) # Initialize 377 (?: 378 (?(?{ $c == 0 }) # PREVIOUS iteration was OK, stop the loop 379 (?! 380 ) # Fail: will unwind one iteration back 381 ) 382 (?: 383 [^()]+ # Match a big chunk 384 (?= 385 [()] 386 ) # Do not try to match subchunks 387 | 388 \( 389 (?{ ++$c }) 390 | 391 \) 392 (?{ --$c }) 393 ) 394 )+ # This may not match with different subblocks 395 ) 396 (?(?{ $c != 0 }) 397 (?! 398 ) # Fail 399 ) # Otherwise the chunk 1 may succeed with $c>0 400 /xg; 401 } 402 403 my @ans = (); 404 my $res; 405 push @ans, $res while $res = matchit; 406 is("@ans", "1 1 1", $message); 407 408 @ans = matchit; 409 is("@ans", $expect, $message); 410 411 $message = "Recursion with (??{ })"; 412 our $matched; 413 $matched = qr/\((?:(?>[^()]+)|(??{$matched}))*\)/; 414 415 @ans = my @ans1 = (); 416 push (@ans, $res), push (@ans1, $&) while $res = m/$matched/g; 417 418 is("@ans", "1 1 1", $message); 419 is("@ans1", $expect, $message); 420 421 @ans = m/$matched/g; 422 is("@ans", $expect, $message); 423 424 } 425 426 { 427 ok "abc" =~ /^(??{"a"})b/, '"abc" =~ /^(??{"a"})b/'; 428 } 429 430 { 431 my @ans = ('a/b' =~ m%(.*/)?(.*)%); # Stack may be bad 432 is("@ans", 'a/ b', "Stack may be bad"); 433 } 434 435 { 436 my $message = "Eval-group not allowed at runtime"; 437 my $code = '{$blah = 45}'; 438 our $blah = 12; 439 eval { /(?$code)/ }; 440 ok($@ && $@ =~ /not allowed at runtime/ && $blah == 12, $message); 441 442 $blah = 12; 443 my $res = eval { "xx" =~ /(?$code)/o }; 444 { 445 no warnings 'uninitialized'; 446 chomp $@; my $message = "$message '$@', '$res', '$blah'"; 447 ok($@ && $@ =~ /not allowed at runtime/ && $blah == 12, $message); 448 } 449 450 $code = '=xx'; 451 $blah = 12; 452 $res = eval { "xx" =~ /(?$code)/o }; 453 { 454 no warnings 'uninitialized'; 455 my $message = "$message '$@', '$res', '$blah'"; 456 ok(!$@ && $res, $message); 457 } 458 459 $code = '{$blah = 45}'; 460 $blah = 12; 461 eval "/(?$code)/"; 462 is($blah, 45, $message); 463 464 $blah = 12; 465 /(?{$blah = 45})/; 466 is($blah, 45, $message); 467 } 468 469 { 470 my $message = "Pos checks"; 471 my $x = 'banana'; 472 $x =~ /.a/g; 473 is(pos $x, 2, $message); 474 475 $x =~ /.z/gc; 476 is(pos $x, 2, $message); 477 478 sub f { 479 my $p = $_[0]; 480 return $p; 481 } 482 483 $x =~ /.a/g; 484 is(f (pos $x), 4, $message); 485 } 486 487 { 488 my $message = 'Checking $^R'; 489 our $x = $^R = 67; 490 'foot' =~ /foo(?{$x = 12; 75})[t]/; 491 is($^R, 75, $message); 492 493 $x = $^R = 67; 494 'foot' =~ /foo(?{$x = 12; 75})[xy]/; 495 ok($^R eq '67' && $x eq '12', $message); 496 497 $x = $^R = 67; 498 'foot' =~ /foo(?{ $^R + 12 })((?{ $x = 12; $^R + 17 })[xy])?/; 499 ok($^R eq '79' && $x eq '12', $message); 500 } 501 502 { 503 is(qr/\b\v$/i, '(?^i:\b\v$)', 'qr/\b\v$/i'); 504 is(qr/\b\v$/s, '(?^s:\b\v$)', 'qr/\b\v$/s'); 505 is(qr/\b\v$/m, '(?^m:\b\v$)', 'qr/\b\v$/m'); 506 is(qr/\b\v$/x, '(?^x:\b\v$)', 'qr/\b\v$/x'); 507 is(qr/\b\v$/xism, '(?^msix:\b\v$)', 'qr/\b\v$/xism'); 508 is(qr/\b\v$/, '(?^:\b\v$)', 'qr/\b\v$/'); 509 } 510 511 { # Test that charset modifier work, and are interpolated 512 is(qr/\b\v$/, '(?^:\b\v$)', 'Verify no locale, no unicode_strings gives default modifier'); 513 is(qr/(?l:\b\v$)/, '(?^:(?l:\b\v$))', 'Verify infix l modifier compiles'); 514 is(qr/(?u:\b\v$)/, '(?^:(?u:\b\v$))', 'Verify infix u modifier compiles'); 515 is(qr/(?l)\b\v$/, '(?^:(?l)\b\v$)', 'Verify (?l) compiles'); 516 is(qr/(?u)\b\v$/, '(?^:(?u)\b\v$)', 'Verify (?u) compiles'); 517 518 my $dual = qr/\b\v$/; 519 use locale; 520 my $locale = qr/\b\v$/; 521 is($locale, '(?^l:\b\v$)', 'Verify has l modifier when compiled under use locale'); 522 no locale; 523 524 use feature 'unicode_strings'; 525 my $unicode = qr/\b\v$/; 526 is($unicode, '(?^u:\b\v$)', 'Verify has u modifier when compiled under unicode_strings'); 527 is(qr/abc$dual/, '(?^u:abc(?^:\b\v$))', 'Verify retains d meaning when interpolated under locale'); 528 is(qr/abc$locale/, '(?^u:abc(?^l:\b\v$))', 'Verify retains l when interpolated under unicode_strings'); 529 530 no feature 'unicode_strings'; 531 is(qr/abc$locale/, '(?^:abc(?^l:\b\v$))', 'Verify retains l when interpolated outside locale and unicode strings'); 532 is(qr/def$unicode/, '(?^:def(?^u:\b\v$))', 'Verify retains u when interpolated outside locale and unicode strings'); 533 534 use locale; 535 is(qr/abc$dual/, '(?^l:abc(?^:\b\v$))', 'Verify retains d meaning when interpolated under locale'); 536 is(qr/abc$unicode/, '(?^l:abc(?^u:\b\v$))', 'Verify retains u when interpolated under locale'); 537 } 538 539 { 540 my $message = "Look around"; 541 $_ = 'xabcx'; 542 foreach my $ans ('', 'c') { 543 ok(/(?<=(?=a)..)((?=c)|.)/g, $message); 544 is($1, $ans, $message); 545 } 546 } 547 548 { 549 my $message = "Empty clause"; 550 $_ = 'a'; 551 foreach my $ans ('', 'a', '') { 552 ok(/^|a|$/g, $message); 553 is($&, $ans, $message); 554 } 555 } 556 557 { 558 sub prefixify { 559 my $message = "Prefixify"; 560 { 561 my ($v, $a, $b, $res) = @_; 562 ok($v =~ s/\Q$a\E/$b/, $message); 563 is($v, $res, $message); 564 } 565 } 566 567 prefixify ('/a/b/lib/arch', "/a/b/lib", 'X/lib', 'X/lib/arch'); 568 prefixify ('/a/b/man/arch', "/a/b/man", 'X/man', 'X/man/arch'); 569 } 570 571 { 572 $_ = 'var="foo"'; 573 /(\")/; 574 ok $1 && /$1/, "Capture a quote"; 575 } 576 577 { 578 no warnings 'closure'; 579 my $message = '(?{ $var } refers to package vars'; 580 package aa; 581 our $c = 2; 582 $::c = 3; 583 '' =~ /(?{ $c = 4 })/; 584 main::is($c, 4, $message); 585 main::is($::c, 3, $message); 586 } 587 588 { 589 is(eval 'q(a:[b]:) =~ /[x[:foo:]]/', undef); 590 like ($@, qr/POSIX class \[:[^:]+:\] unknown in regex/, 591 'POSIX class [: :] must have valid name'); 592 593 for my $d (qw [= .]) { 594 is(eval "/[[${d}foo${d}]]/", undef); 595 like ($@, qr/\QPOSIX syntax [$d $d] is reserved for future extensions/, 596 "POSIX syntax [[$d $d]] is an error"); 597 } 598 } 599 600 { 601 # test if failure of patterns returns empty list 602 my $message = "Failed pattern returns empty list"; 603 $_ = 'aaa'; 604 @_ = /bbb/; 605 is("@_", "", $message); 606 607 @_ = /bbb/g; 608 is("@_", "", $message); 609 610 @_ = /(bbb)/; 611 is("@_", "", $message); 612 613 @_ = /(bbb)/g; 614 is("@_", "", $message); 615 } 616 617 { 618 my $message = '@- and @+ tests'; 619 620 /a(?=.$)/; 621 is($#+, 0, $message); 622 is($#-, 0, $message); 623 is($+ [0], 2, $message); 624 is($- [0], 1, $message); 625 ok(!defined $+ [1] && !defined $- [1] && 626 !defined $+ [2] && !defined $- [2], $message); 627 628 /a(a)(a)/; 629 is($#+, 2, $message); 630 is($#-, 2, $message); 631 is($+ [0], 3, $message); 632 is($- [0], 0, $message); 633 is($+ [1], 2, $message); 634 is($- [1], 1, $message); 635 is($+ [2], 3, $message); 636 is($- [2], 2, $message); 637 ok(!defined $+ [3] && !defined $- [3] && 638 !defined $+ [4] && !defined $- [4], $message); 639 640 # Exists has a special check for @-/@+ - bug 45147 641 ok(exists $-[0], $message); 642 ok(exists $+[0], $message); 643 ok(exists $-[2], $message); 644 ok(exists $+[2], $message); 645 ok(!exists $-[3], $message); 646 ok(!exists $+[3], $message); 647 ok(exists $-[-1], $message); 648 ok(exists $+[-1], $message); 649 ok(exists $-[-3], $message); 650 ok(exists $+[-3], $message); 651 ok(!exists $-[-4], $message); 652 ok(!exists $+[-4], $message); 653 654 /.(a)(b)?(a)/; 655 is($#+, 3, $message); 656 is($#-, 3, $message); 657 is($+ [1], 2, $message); 658 is($- [1], 1, $message); 659 is($+ [3], 3, $message); 660 is($- [3], 2, $message); 661 ok(!defined $+ [2] && !defined $- [2] && 662 !defined $+ [4] && !defined $- [4], $message); 663 664 /.(a)/; 665 is($#+, 1, $message); 666 is($#-, 1, $message); 667 is($+ [0], 2, $message); 668 is($- [0], 0, $message); 669 is($+ [1], 2, $message); 670 is($- [1], 1, $message); 671 ok(!defined $+ [2] && !defined $- [2] && 672 !defined $+ [3] && !defined $- [3], $message); 673 674 /.(a)(ba*)?/; 675 is($#+, 2, $message); 676 is($#-, 1, $message); 677 } 678 679 foreach ('$+[0] = 13', '$-[0] = 13', '@+ = (7, 6, 5)', '@- = qw (foo bar)') { 680 is(eval $_, undef); 681 like($@, qr/^Modification of a read-only value attempted/, 682 'Elements of @- and @+ are read-only'); 683 } 684 685 { 686 my $message = '\G testing'; 687 $_ = 'aaa'; 688 pos = 1; 689 my @a = /\Ga/g; 690 is("@a", "a a", $message); 691 692 my $str = 'abcde'; 693 pos $str = 2; 694 unlike($str, qr/^\G/, $message); 695 unlike($str, qr/^.\G/, $message); 696 like($str, qr/^..\G/, $message); 697 unlike($str, qr/^...\G/, $message); 698 ok($str =~ /\G../ && $& eq 'cd', $message); 699 700 local $::TODO = $::running_as_thread; 701 ok($str =~ /.\G./ && $& eq 'bc', $message); 702 } 703 704 { 705 my $message = 'pos inside (?{ })'; 706 my $str = 'abcde'; 707 our ($foo, $bar); 708 like($str, qr/b(?{$foo = $_; $bar = pos})c/, $message); 709 is($foo, $str, $message); 710 is($bar, 2, $message); 711 is(pos $str, undef, $message); 712 713 undef $foo; 714 undef $bar; 715 pos $str = undef; 716 ok($str =~ /b(?{$foo = $_; $bar = pos})c/g, $message); 717 is($foo, $str, $message); 718 is($bar, 2, $message); 719 is(pos $str, 3, $message); 720 721 $_ = $str; 722 undef $foo; 723 undef $bar; 724 like($_, qr/b(?{$foo = $_; $bar = pos})c/, $message); 725 is($foo, $str, $message); 726 is($bar, 2, $message); 727 728 undef $foo; 729 undef $bar; 730 ok(/b(?{$foo = $_; $bar = pos})c/g, $message); 731 is($foo, $str, $message); 732 is($bar, 2, $message); 733 is(pos, 3, $message); 734 735 undef $foo; 736 undef $bar; 737 pos = undef; 738 1 while /b(?{$foo = $_; $bar = pos})c/g; 739 is($foo, $str, $message); 740 is($bar, 2, $message); 741 is(pos, undef, $message); 742 743 undef $foo; 744 undef $bar; 745 $_ = 'abcde|abcde'; 746 ok(s/b(?{$foo = $_; $bar = pos})c/x/g, $message); 747 is($foo, 'abcde|abcde', $message); 748 is($bar, 8, $message); 749 is($_, 'axde|axde', $message); 750 751 # List context: 752 $_ = 'abcde|abcde'; 753 our @res; 754 () = /([ace]).(?{push @res, $1,$2})([ce])(?{push @res, $1,$2})/g; 755 @res = map {defined $_ ? "'$_'" : 'undef'} @res; 756 is("@res", "'a' undef 'a' 'c' 'e' undef 'a' undef 'a' 'c'", $message); 757 758 @res = (); 759 () = /([ace]).(?{push @res, $`,$&,$'})([ce])(?{push @res, $`,$&,$'})/g; 760 @res = map {defined $_ ? "'$_'" : 'undef'} @res; 761 is("@res", "'' 'ab' 'cde|abcde' " . 762 "'' 'abc' 'de|abcde' " . 763 "'abcd' 'e|' 'abcde' " . 764 "'abcde|' 'ab' 'cde' " . 765 "'abcde|' 'abc' 'de'", $message); 766 } 767 768 { 769 my $message = '\G anchor checks'; 770 my $foo = 'aabbccddeeffgg'; 771 pos ($foo) = 1; 772 { 773 local $::TODO = $::running_as_thread; 774 no warnings 'uninitialized'; 775 ok($foo =~ /.\G(..)/g, $message); 776 is($1, 'ab', $message); 777 778 pos ($foo) += 1; 779 ok($foo =~ /.\G(..)/g, $message); 780 is($1, 'cc', $message); 781 782 pos ($foo) += 1; 783 ok($foo =~ /.\G(..)/g, $message); 784 is($1, 'de', $message); 785 786 ok($foo =~ /\Gef/g, $message); 787 } 788 789 undef pos $foo; 790 ok($foo =~ /\G(..)/g, $message); 791 is($1, 'aa', $message); 792 793 ok($foo =~ /\G(..)/g, $message); 794 is($1, 'bb', $message); 795 796 pos ($foo) = 5; 797 ok($foo =~ /\G(..)/g, $message); 798 is($1, 'cd', $message); 799 } 800 801 { 802 $_ = '123x123'; 803 my @res = /(\d*|x)/g; 804 local $" = '|'; 805 is("@res", "123||x|123|", "0 match in alternation"); 806 } 807 808 { 809 my $message = "Match against temporaries (created via pp_helem())" . 810 " is safe"; 811 ok({foo => "bar\n" . $^X} -> {foo} =~ /^(.*)\n/g, $message); 812 is($1, "bar", $message); 813 } 814 815 { 816 my $message = 'package $i inside (?{ }), ' . 817 'saved substrings and changing $_'; 818 our @a = qw [foo bar]; 819 our @b = (); 820 s/(\w)(?{push @b, $1})/,$1,/g for @a; 821 is("@b", "f o o b a r", $message); 822 is("@a", ",f,,o,,o, ,b,,a,,r,", $message); 823 824 $message = 'lexical $i inside (?{ }), ' . 825 'saved substrings and changing $_'; 826 no warnings 'closure'; 827 my @c = qw [foo bar]; 828 my @d = (); 829 s/(\w)(?{push @d, $1})/,$1,/g for @c; 830 is("@d", "f o o b a r", $message); 831 is("@c", ",f,,o,,o, ,b,,a,,r,", $message); 832 } 833 834 { 835 my $message = 'Brackets'; 836 our $brackets; 837 $brackets = qr { 838 { (?> [^{}]+ | (??{ $brackets }) )* } 839 }x; 840 841 ok("{{}" =~ $brackets, $message); 842 is($&, "{}", $message); 843 ok("something { long { and } hairy" =~ $brackets, $message); 844 is($&, "{ and }", $message); 845 ok("something { long { and } hairy" =~ m/((??{ $brackets }))/, $message); 846 is($&, "{ and }", $message); 847 } 848 849 { 850 $_ = "a-a\nxbb"; 851 pos = 1; 852 ok(!m/^-.*bb/mg, '$_ = "a-a\nxbb"; m/^-.*bb/mg'); 853 } 854 855 { 856 my $message = '\G anchor checks'; 857 my $text = "aaXbXcc"; 858 pos ($text) = 0; 859 ok($text !~ /\GXb*X/g, $message); 860 } 861 862 { 863 $_ = "xA\n" x 500; 864 unlike($_, qr/^\s*A/m, '$_ = "xA\n" x 500; /^\s*A/m"'); 865 866 my $text = "abc dbf"; 867 my @res = ($text =~ /.*?(b).*?\b/g); 868 is("@res", "b b", '\b is not special'); 869 } 870 871 { 872 my $message = '\S, [\S], \s, [\s]'; 873 my @a = map chr, 0 .. 255; 874 my @b = grep m/\S/, @a; 875 my @c = grep m/[^\s]/, @a; 876 is("@b", "@c", $message); 877 878 @b = grep /\S/, @a; 879 @c = grep /[\S]/, @a; 880 is("@b", "@c", $message); 881 882 @b = grep /\s/, @a; 883 @c = grep /[^\S]/, @a; 884 is("@b", "@c", $message); 885 886 @b = grep /\s/, @a; 887 @c = grep /[\s]/, @a; 888 is("@b", "@c", $message); 889 } 890 { 891 my $message = '\D, [\D], \d, [\d]'; 892 my @a = map chr, 0 .. 255; 893 my @b = grep /\D/, @a; 894 my @c = grep /[^\d]/, @a; 895 is("@b", "@c", $message); 896 897 @b = grep /\D/, @a; 898 @c = grep /[\D]/, @a; 899 is("@b", "@c", $message); 900 901 @b = grep /\d/, @a; 902 @c = grep /[^\D]/, @a; 903 is("@b", "@c", $message); 904 905 @b = grep /\d/, @a; 906 @c = grep /[\d]/, @a; 907 is("@b", "@c", $message); 908 } 909 { 910 my $message = '\W, [\W], \w, [\w]'; 911 my @a = map chr, 0 .. 255; 912 my @b = grep /\W/, @a; 913 my @c = grep /[^\w]/, @a; 914 is("@b", "@c", $message); 915 916 @b = grep /\W/, @a; 917 @c = grep /[\W]/, @a; 918 is("@b", "@c", $message); 919 920 @b = grep /\w/, @a; 921 @c = grep /[^\W]/, @a; 922 is("@b", "@c", $message); 923 924 @b = grep /\w/, @a; 925 @c = grep /[\w]/, @a; 926 is("@b", "@c", $message); 927 } 928 929 { 930 # see if backtracking optimization works correctly 931 my $message = 'Backtrack optimization'; 932 like("\n\n", qr/\n $ \n/x, $message); 933 like("\n\n", qr/\n* $ \n/x, $message); 934 like("\n\n", qr/\n+ $ \n/x, $message); 935 like("\n\n", qr/\n? $ \n/x, $message); 936 like("\n\n", qr/\n*? $ \n/x, $message); 937 like("\n\n", qr/\n+? $ \n/x, $message); 938 like("\n\n", qr/\n?? $ \n/x, $message); 939 unlike("\n\n", qr/\n*+ $ \n/x, $message); 940 unlike("\n\n", qr/\n++ $ \n/x, $message); 941 like("\n\n", qr/\n?+ $ \n/x, $message); 942 } 943 944 { 945 package S; 946 use overload '""' => sub {'Object S'}; 947 sub new {bless []} 948 949 my $message = "Ref stringification"; 950 ::ok(do { \my $v} =~ /^SCALAR/, "Scalar ref stringification") or diag($message); 951 ::ok(do {\\my $v} =~ /^REF/, "Ref ref stringification") or diag($message); 952 ::ok([] =~ /^ARRAY/, "Array ref stringification") or diag($message); 953 ::ok({} =~ /^HASH/, "Hash ref stringification") or diag($message); 954 ::ok('S' -> new =~ /^Object S/, "Object stringification") or diag($message); 955 } 956 957 { 958 my $message = "Test result of match used as match"; 959 ok('a1b' =~ ('xyz' =~ /y/), $message); 960 is($`, 'a', $message); 961 ok('a1b' =~ ('xyz' =~ /t/), $message); 962 is($`, 'a', $message); 963 } 964 965 { 966 my $message = '"1" is not \s'; 967 warning_is(sub {unlike("1\n" x 102, qr/^\s*\n/m, $message)}, 968 undef, "$message (did not warn)"); 969 } 970 971 { 972 my $message = '\s, [[:space:]] and [[:blank:]]'; 973 my %space = (spc => " ", 974 tab => "\t", 975 cr => "\r", 976 lf => "\n", 977 ff => "\f", 978 # There's no \v but the vertical tabulator seems miraculously 979 # be 11 both in ASCII and EBCDIC. 980 vt => chr(11), 981 false => "space"); 982 983 my @space0 = sort grep {$space {$_} =~ /\s/ } keys %space; 984 my @space1 = sort grep {$space {$_} =~ /[[:space:]]/} keys %space; 985 my @space2 = sort grep {$space {$_} =~ /[[:blank:]]/} keys %space; 986 987 is("@space0", "cr ff lf spc tab", $message); 988 is("@space1", "cr ff lf spc tab vt", $message); 989 is("@space2", "spc tab", $message); 990 } 991 992 { 993 my $n= 50; 994 # this must be a high number and go from 0 to N, as the bug we are looking for doesn't 995 # seem to be predictable. Slight changes to the test make it fail earlier or later. 996 foreach my $i (0 .. $n) 997 { 998 my $str= "\n" x $i; 999 ok $str=~/.*\z/, "implicit MBOL check string disable does not break things length=$i"; 1000 } 1001 } 1002 { 1003 # we are actually testing that we dont die when executing these patterns 1004 use utf8; 1005 my $e = "Böck"; 1006 ok(utf8::is_utf8($e),"got a unicode string - rt75680"); 1007 1008 ok($e !~ m/.*?[x]$/, "unicode string against /.*?[x]\$/ - rt75680"); 1009 ok($e !~ m/.*?\p{Space}$/i, "unicode string against /.*?\\p{space}\$/i - rt75680"); 1010 ok($e !~ m/.*?[xyz]$/, "unicode string against /.*?[xyz]\$/ - rt75680"); 1011 ok($e !~ m/(.*?)[,\p{isSpace}]+((?:\p{isAlpha}[\p{isSpace}\.]{1,2})+)\p{isSpace}*$/, "unicode string against big pattern - rt75680"); 1012 } 1013 { 1014 # we are actually testing that we dont die when executing these patterns 1015 my $e = "B\x{f6}ck"; 1016 ok(!utf8::is_utf8($e), "got a latin string - rt75680"); 1017 1018 ok($e !~ m/.*?[x]$/, "latin string against /.*?[x]\$/ - rt75680"); 1019 ok($e !~ m/.*?\p{Space}$/i, "latin string against /.*?\\p{space}\$/i - rt75680"); 1020 ok($e !~ m/.*?[xyz]$/,"latin string against /.*?[xyz]\$/ - rt75680"); 1021 ok($e !~ m/(.*?)[,\p{isSpace}]+((?:\p{isAlpha}[\p{isSpace}\.]{1,2})+)\p{isSpace}*$/,"latin string against big pattern - rt75680"); 1022 } 1023 1024 { 1025 # 1026 # Tests for bug 77414. 1027 # 1028 1029 my $message = '\p property after empty * match'; 1030 { 1031 like("1", qr/\s*\pN/, $message); 1032 like("-", qr/\s*\p{Dash}/, $message); 1033 like(" ", qr/\w*\p{Blank}/, $message); 1034 } 1035 1036 like("1", qr/\s*\pN+/, $message); 1037 like("-", qr/\s*\p{Dash}{1}/, $message); 1038 like(" ", qr/\w*\p{Blank}{1,4}/, $message); 1039 1040 } 1041 1042 SKIP: { # Some constructs with Latin1 characters cause a utf8 string not 1043 # to match itself in non-utf8 1044 if ($::IS_EBCDIC) { 1045 skip "Needs to be customized to run on EBCDIC", 6; 1046 } 1047 my $c = "\xc0"; 1048 my $pattern = my $utf8_pattern = qr/((\xc0)+,?)/; 1049 utf8::upgrade($utf8_pattern); 1050 ok $c =~ $pattern, "\\xc0 =~ $pattern; Neither pattern nor target utf8"; 1051 ok $c =~ /$pattern/i, "\\xc0 =~ /$pattern/i; Neither pattern nor target utf8"; 1052 ok $c =~ $utf8_pattern, "\\xc0 =~ $pattern; pattern utf8, target not"; 1053 ok $c =~ /$utf8_pattern/i, "\\xc0 =~ /$pattern/i; pattern utf8, target not"; 1054 utf8::upgrade($c); 1055 ok $c =~ $pattern, "\\xc0 =~ $pattern; target utf8, pattern not"; 1056 ok $c =~ /$pattern/i, "\\xc0 =~ /$pattern/i; target utf8, pattern not"; 1057 ok $c =~ $utf8_pattern, "\\xc0 =~ $pattern; Both target and pattern utf8"; 1058 ok $c =~ /$utf8_pattern/i, "\\xc0 =~ /$pattern/i; Both target and pattern utf8"; 1059 } 1060 1061 SKIP: { # Make sure can override the formatting 1062 if ($::IS_EBCDIC) { 1063 skip "Needs to be customized to run on EBCDIC", 2; 1064 } 1065 use feature 'unicode_strings'; 1066 ok "\xc0" =~ /\w/, 'Under unicode_strings: "\xc0" =~ /\w/'; 1067 ok "\xc0" !~ /(?d:\w)/, 'Under unicode_strings: "\xc0" !~ /(?d:\w)/'; 1068 } 1069 1070 { 1071 # Test that a regex followed by an operator and/or a statement modifier work 1072 # These tests use string-eval so that it reports a clean error when it fails 1073 # (without the string eval the test script might be unparseable) 1074 1075 # Note: these test check the behaviour that currently is valid syntax 1076 # If a new regex modifier is added and a test fails then there is a backwards-compatibility issue 1077 # Note-2: a new deprecate warning was added for this with commit e6897b1a5db0410e387ccbf677e89fc4a1d8c97a 1078 # which indicate that this syntax will be removed in 5.16. 1079 # When this happens the tests can be removed 1080 1081 foreach (['my $r = "a" =~ m/a/lt 2', 'm', 'lt'], 1082 ['my $r = "a" =~ m/a/le 1', 'm', 'le'], 1083 ['my $r = "a" =~ m/a/eq 1', 'm', 'eq'], 1084 ['my $r = "a" =~ m/a/ne 0', 'm', 'ne'], 1085 ['my $r = "a" =~ m/a/and 1', 'm', 'and'], 1086 ['my $r = "a" =~ m/a/unless 0', 'm', 'unless'], 1087 ['my $c = 1; my $r; $r = "a" =~ m/a/while $c--', 'm', 'while'], 1088 ['my $c = 0; my $r; $r = "a" =~ m/a/until $c++', 'm', 'until'], 1089 ['my $r; $r = "a" =~ m/a/for 1', 'm', 'for'], 1090 ['my $r; $r = "a" =~ m/a/foreach 1', 'm', 'foreach'], 1091 1092 ['my $t = "a"; my $r = $t =~ s/a//lt 2', 's', 'lt'], 1093 ['my $t = "a"; my $r = $t =~ s/a//le 1', 's', 'le'], 1094 ['my $t = "a"; my $r = $t =~ s/a//ne 0', 's', 'ne'], 1095 ['my $t = "a"; my $r = $t =~ s/a//and 1', 's', 'and'], 1096 ['my $t = "a"; my $r = $t =~ s/a//unless 0', 's', 'unless'], 1097 1098 ['my $c = 1; my $r; my $t = "a"; $r = $t =~ s/a//while $c--', 's', 'while'], 1099 ['my $c = 0; my $r; my $t = "a"; $r = $t =~ s/a//until $c++', 's', 'until'], 1100 ['my $r; my $t = "a"; $r = $t =~ s/a//for 1', 's', 'for'], 1101 ['my $r; my $t = "a"; $r = $t =~ s/a//for 1', 's', 'foreach'], 1102 ) { 1103 my $message = sprintf 'regex (%s) followed by $_->[2]', 1104 $_->[1] eq 'm' ? 'm//' : 's///'; 1105 my $code = "$_->[0]; 'eval_ok ' . \$r"; 1106 my $result = do { 1107 no warnings 'syntax'; 1108 eval $code; 1109 }; 1110 is($@, '', $message); 1111 is($result, 'eval_ok 1', $message); 1112 } 1113 } 1114 1115 { 1116 my $str= "\x{100}"; 1117 chop $str; 1118 my $qr= qr/$str/; 1119 is("$qr", "(?^:)", "Empty pattern qr// stringifies to (?^:) with unicode flag enabled - Bug #80212"); 1120 $str= ""; 1121 $qr= qr/$str/; 1122 is("$qr", "(?^:)", "Empty pattern qr// stringifies to (?^:) with unicode flag disabled - Bug #80212"); 1123 1124 } 1125 1126 { 1127 local $::TODO = "[perl #38133]"; 1128 1129 "A" =~ /(((?:A))?)+/; 1130 my $first = $2; 1131 1132 "A" =~ /(((A))?)+/; 1133 my $second = $2; 1134 1135 is($first, $second); 1136 } 1137 1138 { 1139 # RT #3516: \G in a m//g expression causes problems 1140 my $count = 0; 1141 while ("abc" =~ m/(\G[ac])?/g) { 1142 last if $count++ > 10; 1143 } 1144 ok($count < 10, 'RT #3516 A'); 1145 1146 $count = 0; 1147 while ("abc" =~ m/(\G|.)[ac]/g) { 1148 last if $count++ > 10; 1149 } 1150 ok($count < 10, 'RT #3516 B'); 1151 1152 $count = 0; 1153 while ("abc" =~ m/(\G?[ac])?/g) { 1154 last if $count++ > 10; 1155 } 1156 ok($count < 10, 'RT #3516 C'); 1157 } 1158 { 1159 # RT #84294: Is this a bug in the simple Perl regex? 1160 # : Nested buffers and (?{...}) dont play nicely on partial matches 1161 our @got= (); 1162 ok("ab" =~ /((\w+)(?{ push @got, $2 })){2}/,"RT #84294: Pattern should match"); 1163 my $want= "'ab', 'a', 'b'"; 1164 my $got= join(", ", map { defined($_) ? "'$_'" : "undef" } @got); 1165 is($got,$want,'RT #84294: check that "ab" =~ /((\w+)(?{ push @got, $2 })){2}/ leaves @got in the correct state'); 1166 } 1167 1168 { 1169 # Suppress warnings, as the non-unicode one comes out even if turn off 1170 # warnings here (because the execution is done in another scope). 1171 local $SIG{__WARN__} = sub {}; 1172 my $str = "\x{110000}"; 1173 1174 # No non-unicode code points match any Unicode property, even inverse 1175 # ones 1176 unlike($str, qr/\p{ASCII_Hex_Digit=True}/, "Non-Unicode doesn't match \\p{}"); 1177 unlike($str, qr/\p{ASCII_Hex_Digit=False}/, "Non-Unicode doesn't match \\p{}"); 1178 like($str, qr/\P{ASCII_Hex_Digit=True}/, "Non-Unicode matches \\P{}"); 1179 like($str, qr/\P{ASCII_Hex_Digit=False}/, "Non-Unicode matches \\P{}"); 1180 } 1181 1182 { 1183 # Test that IDstart works, but because the author (khw) knows 1184 # regexes much better than the rest of the core, it is being done here 1185 # in the context of a regex which relies on buffer names beginng with 1186 # IDStarts. 1187 use utf8; 1188 my $str = "abc"; 1189 like($str, qr/(?<a>abc)/, "'a' is legal IDStart"); 1190 like($str, qr/(?<_>abc)/, "'_' is legal IDStart"); 1191 like($str, qr/(?<ß>abc)/, "U+00DF is legal IDStart"); 1192 like($str, qr/(?<ℕ>abc)/, "U+2115' is legal IDStart"); 1193 1194 # This test works on Unicode 6.0 in which U+2118 and U+212E are legal 1195 # IDStarts there, but are not Word characters, and therefore Perl 1196 # doesn't allow them to be IDStarts. But there is no guarantee that 1197 # Unicode won't change things around in the future so that at some 1198 # future Unicode revision these tests would need to be revised. 1199 foreach my $char ("%", "×", chr(0x2118), chr(0x212E)) { 1200 my $prog = <<"EOP"; 1201use utf8;; 1202"abc" =~ qr/(?<$char>abc)/; 1203EOP 1204 utf8::encode($prog); 1205 fresh_perl_like($prog, qr!Sequence.* not recognized!, "", 1206 sprintf("'U+%04X not legal IDFirst'", ord($char))); 1207 } 1208 } 1209 1210 { # [perl #101710] 1211 my $pat = "b"; 1212 utf8::upgrade($pat); 1213 like("\xffb", qr/$pat/i, "/i: utf8 pattern, non-utf8 string, latin1-char preceding matching char in string"); 1214 } 1215 1216 { # Crash with @a =~ // warning 1217 local $SIG{__WARN__} = sub { 1218 pass 'no crash for @a =~ // warning' 1219 }; 1220 eval ' sub { my @a =~ // } '; 1221 } 1222 1223 { # Concat overloading and qr// thingies 1224 my @refs; 1225 my $qr = qr//; 1226 package Cat { 1227 require overload; 1228 overload->import( 1229 '""' => sub { ${$_[0]} }, 1230 '.' => sub { 1231 push @refs, ref $_[1] if ref $_[1]; 1232 bless $_[2] ? \"$_[1]${$_[0]}" : \"${$_[0]}$_[1]" 1233 } 1234 ); 1235 } 1236 my $s = "foo"; 1237 my $o = bless \$s, Cat::; 1238 /$o$qr/; 1239 is "@refs", "Regexp", '/$o$qr/ passes qr ref to cat overload meth'; 1240 } 1241 1242 { 1243 my $count=0; 1244 my $str="\n"; 1245 $count++ while $str=~/.*/g; 1246 is $count, 2, 'test that ANCH_MBOL works properly. We should get 2 from $count++ while "\n"=~/.*/g'; 1247 my $class_count= 0; 1248 $class_count++ while $str=~/[^\n]*/g; 1249 is $class_count, $count, 'while "\n"=~/.*/g and while "\n"=~/[^\n]*/g should behave the same'; 1250 my $anch_count= 0; 1251 $anch_count++ while $str=~/^.*/mg; 1252 is $anch_count, 1, 'while "\n"=~/^.*/mg should match only once'; 1253 } 1254 1255 { # [perl #111174] 1256 use re '/u'; 1257 like "\xe0", qr/(?i:\xc0)/, "(?i: shouldn't lose the passed in /u"; 1258 use re '/a'; 1259 unlike "\x{100}", qr/(?i:\w)/, "(?i: shouldn't lose the passed in /a"; 1260 use re '/aa'; 1261 unlike 'k', qr/(?i:\N{KELVIN SIGN})/, "(?i: shouldn't lose the passed in /aa"; 1262 } 1263} # End of sub run_tests 1264 12651; 1266