1#!./perl -wT 2 3BEGIN { 4 chdir 't' if -d 't'; 5 @INC = '../lib'; 6 require Config; import Config; 7} 8 9require './test.pl'; 10plan( tests => 130 ); 11 12$x = 'foo'; 13$_ = "x"; 14s/x/\$x/; 15ok( $_ eq '$x', ":$_: eq :\$x:" ); 16 17$_ = "x"; 18s/x/$x/; 19ok( $_ eq 'foo', ":$_: eq :foo:" ); 20 21$_ = "x"; 22s/x/\$x $x/; 23ok( $_ eq '$x foo', ":$_: eq :\$x foo:" ); 24 25$b = 'cd'; 26($a = 'abcdef') =~ s<(b${b}e)>'\n$1'; 27ok( $1 eq 'bcde' && $a eq 'a\n$1f', ":$1: eq :bcde: ; :$a: eq :a\\n\$1f:" ); 28 29$a = 'abacada'; 30ok( ($a =~ s/a/x/g) == 4 && $a eq 'xbxcxdx' ); 31 32ok( ($a =~ s/a/y/g) == 0 && $a eq 'xbxcxdx' ); 33 34ok( ($a =~ s/b/y/g) == 1 && $a eq 'xyxcxdx' ); 35 36$_ = 'ABACADA'; 37ok( /a/i && s///gi && $_ eq 'BCD' ); 38 39$_ = '\\' x 4; 40ok( length($_) == 4 ); 41$snum = s/\\/\\\\/g; 42ok( $_ eq '\\' x 8 && $snum == 4 ); 43 44$_ = '\/' x 4; 45ok( length($_) == 8 ); 46$snum = s/\//\/\//g; 47ok( $_ eq '\\//' x 4 && $snum == 4 ); 48ok( length($_) == 12 ); 49 50$_ = 'aaaXXXXbbb'; 51s/^a//; 52ok( $_ eq 'aaXXXXbbb' ); 53 54$_ = 'aaaXXXXbbb'; 55s/a//; 56ok( $_ eq 'aaXXXXbbb' ); 57 58$_ = 'aaaXXXXbbb'; 59s/^a/b/; 60ok( $_ eq 'baaXXXXbbb' ); 61 62$_ = 'aaaXXXXbbb'; 63s/a/b/; 64ok( $_ eq 'baaXXXXbbb' ); 65 66$_ = 'aaaXXXXbbb'; 67s/aa//; 68ok( $_ eq 'aXXXXbbb' ); 69 70$_ = 'aaaXXXXbbb'; 71s/aa/b/; 72ok( $_ eq 'baXXXXbbb' ); 73 74$_ = 'aaaXXXXbbb'; 75s/b$//; 76ok( $_ eq 'aaaXXXXbb' ); 77 78$_ = 'aaaXXXXbbb'; 79s/b//; 80ok( $_ eq 'aaaXXXXbb' ); 81 82$_ = 'aaaXXXXbbb'; 83s/bb//; 84ok( $_ eq 'aaaXXXXb' ); 85 86$_ = 'aaaXXXXbbb'; 87s/aX/y/; 88ok( $_ eq 'aayXXXbbb' ); 89 90$_ = 'aaaXXXXbbb'; 91s/Xb/z/; 92ok( $_ eq 'aaaXXXzbb' ); 93 94$_ = 'aaaXXXXbbb'; 95s/aaX.*Xbb//; 96ok( $_ eq 'ab' ); 97 98$_ = 'aaaXXXXbbb'; 99s/bb/x/; 100ok( $_ eq 'aaaXXXXxb' ); 101 102# now for some unoptimized versions of the same. 103 104$_ = 'aaaXXXXbbb'; 105$x ne $x || s/^a//; 106ok( $_ eq 'aaXXXXbbb' ); 107 108$_ = 'aaaXXXXbbb'; 109$x ne $x || s/a//; 110ok( $_ eq 'aaXXXXbbb' ); 111 112$_ = 'aaaXXXXbbb'; 113$x ne $x || s/^a/b/; 114ok( $_ eq 'baaXXXXbbb' ); 115 116$_ = 'aaaXXXXbbb'; 117$x ne $x || s/a/b/; 118ok( $_ eq 'baaXXXXbbb' ); 119 120$_ = 'aaaXXXXbbb'; 121$x ne $x || s/aa//; 122ok( $_ eq 'aXXXXbbb' ); 123 124$_ = 'aaaXXXXbbb'; 125$x ne $x || s/aa/b/; 126ok( $_ eq 'baXXXXbbb' ); 127 128$_ = 'aaaXXXXbbb'; 129$x ne $x || s/b$//; 130ok( $_ eq 'aaaXXXXbb' ); 131 132$_ = 'aaaXXXXbbb'; 133$x ne $x || s/b//; 134ok( $_ eq 'aaaXXXXbb' ); 135 136$_ = 'aaaXXXXbbb'; 137$x ne $x || s/bb//; 138ok( $_ eq 'aaaXXXXb' ); 139 140$_ = 'aaaXXXXbbb'; 141$x ne $x || s/aX/y/; 142ok( $_ eq 'aayXXXbbb' ); 143 144$_ = 'aaaXXXXbbb'; 145$x ne $x || s/Xb/z/; 146ok( $_ eq 'aaaXXXzbb' ); 147 148$_ = 'aaaXXXXbbb'; 149$x ne $x || s/aaX.*Xbb//; 150ok( $_ eq 'ab' ); 151 152$_ = 'aaaXXXXbbb'; 153$x ne $x || s/bb/x/; 154ok( $_ eq 'aaaXXXXxb' ); 155 156$_ = 'abc123xyz'; 157s/(\d+)/$1*2/e; # yields 'abc246xyz' 158ok( $_ eq 'abc246xyz' ); 159s/(\d+)/sprintf("%5d",$1)/e; # yields 'abc 246xyz' 160ok( $_ eq 'abc 246xyz' ); 161s/(\w)/$1 x 2/eg; # yields 'aabbcc 224466xxyyzz' 162ok( $_ eq 'aabbcc 224466xxyyzz' ); 163 164$_ = "aaaaa"; 165ok( y/a/b/ == 5 ); 166ok( y/a/b/ == 0 ); 167ok( y/b// == 5 ); 168ok( y/b/c/s == 5 ); 169ok( y/c// == 1 ); 170ok( y/c//d == 1 ); 171ok( $_ eq "" ); 172 173$_ = "Now is the %#*! time for all good men..."; 174ok( ($x=(y/a-zA-Z //cd)) == 7 ); 175ok( y/ / /s == 8 ); 176 177$_ = 'abcdefghijklmnopqrstuvwxyz0123456789'; 178tr/a-z/A-Z/; 179 180ok( $_ eq 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789' ); 181 182# same as tr/A-Z/a-z/; 183if (defined $Config{ebcdic} && $Config{ebcdic} eq 'define') { # EBCDIC. 184 no utf8; 185 y[\301-\351][\201-\251]; 186} else { # Ye Olde ASCII. Or something like it. 187 y[\101-\132][\141-\172]; 188} 189 190ok( $_ eq 'abcdefghijklmnopqrstuvwxyz0123456789' ); 191 192SKIP: { 193 skip("not ASCII",1) unless (ord("+") == ord(",") - 1 194 && ord(",") == ord("-") - 1 195 && ord("a") == ord("b") - 1 196 && ord("b") == ord("c") - 1); 197 $_ = '+,-'; 198 tr/+--/a-c/; 199 ok( $_ eq 'abc' ); 200} 201 202$_ = '+,-'; 203tr/+\--/a\/c/; 204ok( $_ eq 'a,/' ); 205 206$_ = '+,-'; 207tr/-+,/ab\-/; 208ok( $_ eq 'b-a' ); 209 210 211# test recursive substitutions 212# code based on the recursive expansion of makefile variables 213 214my %MK = ( 215 AAAAA => '$(B)', B=>'$(C)', C => 'D', # long->short 216 E => '$(F)', F=>'p $(G) q', G => 'HHHHH', # short->long 217 DIR => '$(UNDEFINEDNAME)/xxx', 218); 219sub var { 220 my($var,$level) = @_; 221 return "\$($var)" unless exists $MK{$var}; 222 return exp_vars($MK{$var}, $level+1); # can recurse 223} 224sub exp_vars { 225 my($str,$level) = @_; 226 $str =~ s/\$\((\w+)\)/var($1, $level+1)/ge; # can recurse 227 #warn "exp_vars $level = '$str'\n"; 228 $str; 229} 230 231ok( exp_vars('$(AAAAA)',0) eq 'D' ); 232ok( exp_vars('$(E)',0) eq 'p HHHHH q' ); 233ok( exp_vars('$(DIR)',0) eq '$(UNDEFINEDNAME)/xxx' ); 234ok( exp_vars('foo $(DIR)/yyy bar',0) eq 'foo $(UNDEFINEDNAME)/xxx/yyy bar' ); 235 236$_ = "abcd"; 237s/(..)/$x = $1, m#.#/eg; 238ok( $x eq "cd", 'a match nested in the RHS of a substitution' ); 239 240# Subst and lookbehind 241 242$_="ccccc"; 243$snum = s/(?<!x)c/x/g; 244ok( $_ eq "xxxxx" && $snum == 5 ); 245 246$_="ccccc"; 247$snum = s/(?<!x)(c)/x/g; 248ok( $_ eq "xxxxx" && $snum == 5 ); 249 250$_="foobbarfoobbar"; 251$snum = s/(?<!r)foobbar/foobar/g; 252ok( $_ eq "foobarfoobbar" && $snum == 1 ); 253 254$_="foobbarfoobbar"; 255$snum = s/(?<!ar)(foobbar)/foobar/g; 256ok( $_ eq "foobarfoobbar" && $snum == 1 ); 257 258$_="foobbarfoobbar"; 259$snum = s/(?<!ar)foobbar/foobar/g; 260ok( $_ eq "foobarfoobbar" && $snum == 1 ); 261 262eval 's{foo} # this is a comment, not a delimiter 263 {bar};'; 264ok( ! @?, 'parsing of split subst with comment' ); 265 266$_="baacbaa"; 267$snum = tr/a/b/s; 268ok( $_ eq "bbcbb" && $snum == 4, 269 'check if squashing works at the end of string' ); 270 271$_ = "ab"; 272ok( s/a/b/ == 1 ); 273 274$_ = <<'EOL'; 275 $url = new URI::URL "http://www/"; die if $url eq "xXx"; 276EOL 277$^R = 'junk'; 278 279$foo = ' $@%#lowercase $@%# lowercase UPPERCASE$@%#UPPERCASE' . 280 ' $@%#lowercase$@%#lowercase$@%# lowercase lowercase $@%#lowercase' . 281 ' lowercase $@%#MiXeD$@%# '; 282 283$snum = 284s{ \d+ \b [,.;]? (?{ 'digits' }) 285 | 286 [a-z]+ \b [,.;]? (?{ 'lowercase' }) 287 | 288 [A-Z]+ \b [,.;]? (?{ 'UPPERCASE' }) 289 | 290 [A-Z] [a-z]+ \b [,.;]? (?{ 'Capitalized' }) 291 | 292 [A-Za-z]+ \b [,.;]? (?{ 'MiXeD' }) 293 | 294 [A-Za-z0-9]+ \b [,.;]? (?{ 'alphanumeric' }) 295 | 296 \s+ (?{ ' ' }) 297 | 298 [^A-Za-z0-9\s]+ (?{ '$@%#' }) 299}{$^R}xg; 300ok( $_ eq $foo ); 301ok( $snum == 31 ); 302 303$_ = 'a' x 6; 304$snum = s/a(?{})//g; 305ok( $_ eq '' && $snum == 6 ); 306 307$_ = 'x' x 20; 308$snum = s/(\d*|x)/<$1>/g; 309$foo = '<>' . ('<x><>' x 20) ; 310ok( $_ eq $foo && $snum == 41 ); 311 312$t = 'aaaaaaaaa'; 313 314$_ = $t; 315pos = 6; 316$snum = s/\Ga/xx/g; 317ok( $_ eq 'aaaaaaxxxxxx' && $snum == 3 ); 318 319$_ = $t; 320pos = 6; 321$snum = s/\Ga/x/g; 322ok( $_ eq 'aaaaaaxxx' && $snum == 3 ); 323 324$_ = $t; 325pos = 6; 326s/\Ga/xx/; 327ok( $_ eq 'aaaaaaxxaa' ); 328 329$_ = $t; 330pos = 6; 331s/\Ga/x/; 332ok( $_ eq 'aaaaaaxaa' ); 333 334$_ = $t; 335$snum = s/\Ga/xx/g; 336ok( $_ eq 'xxxxxxxxxxxxxxxxxx' && $snum == 9 ); 337 338$_ = $t; 339$snum = s/\Ga/x/g; 340ok( $_ eq 'xxxxxxxxx' && $snum == 9 ); 341 342$_ = $t; 343s/\Ga/xx/; 344ok( $_ eq 'xxaaaaaaaa' ); 345 346$_ = $t; 347s/\Ga/x/; 348ok( $_ eq 'xaaaaaaaa' ); 349 350$_ = 'aaaa'; 351$snum = s/\ba/./g; 352ok( $_ eq '.aaa' && $snum == 1 ); 353 354eval q% s/a/"b"}/e %; 355ok( $@ =~ /Bad evalled substitution/ ); 356eval q% ($_ = "x") =~ s/(.)/"$1 "/e %; 357ok( $_ eq "x " and !length $@ ); 358$x = $x = 'interp'; 359eval q% ($_ = "x") =~ s/x(($x)*)/"$1"/e %; 360ok( $_ eq '' and !length $@ ); 361 362$_ = "C:/"; 363ok( !s/^([a-z]:)/\u$1/ ); 364 365$_ = "Charles Bronson"; 366$snum = s/\B\w//g; 367ok( $_ eq "C B" && $snum == 12 ); 368 369{ 370 use utf8; 371 my $s = "H\303\266he"; 372 my $l = my $r = $s; 373 $l =~ s/[^\w]//g; 374 $r =~ s/[^\w\.]//g; 375 is($l, $r, "use utf8 \\w"); 376} 377 378my $pv1 = my $pv2 = "Andreas J. K\303\266nig"; 379$pv1 =~ s/A/\x{100}/; 380substr($pv2,0,1) = "\x{100}"; 381is($pv1, $pv2); 382 383SKIP: { 384 skip("EBCDIC", 3) if ord("A") == 193; 385 386 { 387 # Gregor Chrupala <gregor.chrupala@star-group.net> 388 use utf8; 389 $a = 'España'; 390 $a =~ s/ñ/ñ/; 391 like($a, qr/ñ/, "use utf8 RHS"); 392 } 393 394 { 395 use utf8; 396 $a = 'España España'; 397 $a =~ s/ñ/ñ/; 398 like($a, qr/ñ/, "use utf8 LHS"); 399 } 400 401 { 402 use utf8; 403 $a = 'España'; 404 $a =~ s/ñ/ñ/; 405 like($a, qr/ñ/, "use utf8 LHS and RHS"); 406 } 407} 408 409{ 410 # SADAHIRO Tomoyuki <bqw10602@nifty.com> 411 412 $a = "\x{100}\x{101}"; 413 $a =~ s/\x{101}/\xFF/; 414 like($a, qr/\xFF/); 415 is(length($a), 2, "SADAHIRO utf8 s///"); 416 417 $a = "\x{100}\x{101}"; 418 $a =~ s/\x{101}/"\xFF"/e; 419 like($a, qr/\xFF/); 420 is(length($a), 2); 421 422 $a = "\x{100}\x{101}"; 423 $a =~ s/\x{101}/\xFF\xFF\xFF/; 424 like($a, qr/\xFF\xFF\xFF/); 425 is(length($a), 4); 426 427 $a = "\x{100}\x{101}"; 428 $a =~ s/\x{101}/"\xFF\xFF\xFF"/e; 429 like($a, qr/\xFF\xFF\xFF/); 430 is(length($a), 4); 431 432 $a = "\xFF\x{101}"; 433 $a =~ s/\xFF/\x{100}/; 434 like($a, qr/\x{100}/); 435 is(length($a), 2); 436 437 $a = "\xFF\x{101}"; 438 $a =~ s/\xFF/"\x{100}"/e; 439 like($a, qr/\x{100}/); 440 is(length($a), 2); 441 442 $a = "\xFF"; 443 $a =~ s/\xFF/\x{100}/; 444 like($a, qr/\x{100}/); 445 is(length($a), 1); 446 447 $a = "\xFF"; 448 $a =~ s/\xFF/"\x{100}"/e; 449 like($a, qr/\x{100}/); 450 is(length($a), 1); 451} 452 453{ 454 # subst with mixed utf8/non-utf8 type 455 my($ua, $ub, $uc, $ud) = ("\x{101}", "\x{102}", "\x{103}", "\x{104}"); 456 my($na, $nb) = ("\x{ff}", "\x{fe}"); 457 my $a = "$ua--$ub"; 458 my $b; 459 ($b = $a) =~ s/--/$na/; 460 is($b, "$ua$na$ub", "s///: replace non-utf8 into utf8"); 461 ($b = $a) =~ s/--/--$na--/; 462 is($b, "$ua--$na--$ub", "s///: replace long non-utf8 into utf8"); 463 ($b = $a) =~ s/--/$uc/; 464 is($b, "$ua$uc$ub", "s///: replace utf8 into utf8"); 465 ($b = $a) =~ s/--/--$uc--/; 466 is($b, "$ua--$uc--$ub", "s///: replace long utf8 into utf8"); 467 $a = "$na--$nb"; 468 ($b = $a) =~ s/--/$ua/; 469 is($b, "$na$ua$nb", "s///: replace utf8 into non-utf8"); 470 ($b = $a) =~ s/--/--$ua--/; 471 is($b, "$na--$ua--$nb", "s///: replace long utf8 into non-utf8"); 472 473 # now with utf8 pattern 474 $a = "$ua--$ub"; 475 ($b = $a) =~ s/-($ud)?-/$na/; 476 is($b, "$ua$na$ub", "s///: replace non-utf8 into utf8 (utf8 pattern)"); 477 ($b = $a) =~ s/-($ud)?-/--$na--/; 478 is($b, "$ua--$na--$ub", "s///: replace long non-utf8 into utf8 (utf8 pattern)"); 479 ($b = $a) =~ s/-($ud)?-/$uc/; 480 is($b, "$ua$uc$ub", "s///: replace utf8 into utf8 (utf8 pattern)"); 481 ($b = $a) =~ s/-($ud)?-/--$uc--/; 482 is($b, "$ua--$uc--$ub", "s///: replace long utf8 into utf8 (utf8 pattern)"); 483 $a = "$na--$nb"; 484 ($b = $a) =~ s/-($ud)?-/$ua/; 485 is($b, "$na$ua$nb", "s///: replace utf8 into non-utf8 (utf8 pattern)"); 486 ($b = $a) =~ s/-($ud)?-/--$ua--/; 487 is($b, "$na--$ua--$nb", "s///: replace long utf8 into non-utf8 (utf8 pattern)"); 488 ($b = $a) =~ s/-($ud)?-/$na/; 489 is($b, "$na$na$nb", "s///: replace non-utf8 into non-utf8 (utf8 pattern)"); 490 ($b = $a) =~ s/-($ud)?-/--$na--/; 491 is($b, "$na--$na--$nb", "s///: replace long non-utf8 into non-utf8 (utf8 pattern)"); 492} 493 494$_ = 'aaaa'; 495$r = 'x'; 496$s = s/a(?{})/$r/g; 497is("<$_> <$s>", "<xxxx> <4>", "[perl #7806]"); 498 499$_ = 'aaaa'; 500$s = s/a(?{})//g; 501is("<$_> <$s>", "<> <4>", "[perl #7806]"); 502 503# [perl #19048] Coredump in silly replacement 504{ 505 local $^W = 0; 506 $_="abcdef\n"; 507 s!.!!eg; 508 is($_, "\n", "[perl #19048]"); 509} 510 511# [perl #17757] interaction between saw_ampersand and study 512{ 513 my $f = eval q{ $& }; 514 $f = "xx"; 515 study $f; 516 $f =~ s/x/y/g; 517 is($f, "yy", "[perl #17757]"); 518} 519 520# [perl #20684] returned a zero count 521$_ = "1111"; 522is(s/(??{1})/2/eg, 4, '#20684 s/// with (??{..}) inside'); 523 524# [perl #20682] @- not visible in replacement 525$_ = "123"; 526/(2)/; # seed @- with something else 527s/(1)(2)(3)/$#- (@-)/; 528is($_, "3 (0 0 1 2)", '#20682 @- not visible in replacement'); 529 530# [perl #20682] $^N not visible in replacement 531$_ = "abc"; 532/(a)/; s/(b)|(c)/-$^N/g; 533is($_,'a-b-c','#20682 $^N not visible in replacement'); 534 535# [perl #22351] perl bug with 'e' substitution modifier 536my $name = "chris"; 537{ 538 no warnings 'uninitialized'; 539 $name =~ s/hr//e; 540} 541is($name, "cis", q[#22351 bug with 'e' substitution modifier]); 542