| 1 | #!./perl -w |
| 2 | |
| 3 | BEGIN { |
| 4 | chdir 't' if -d 't'; |
| 5 | @INC = '../lib'; |
| 6 | require Config; import Config; |
| 7 | } |
| 8 | |
| 9 | require './test.pl'; |
| 10 | plan( tests => 176 ); |
| 11 | |
| 12 | $_ = 'david'; |
| 13 | $a = s/david/rules/r; |
| 14 | ok( $_ eq 'david' && $a eq 'rules', 'non-destructive substitute' ); |
| 15 | |
| 16 | $a = "david" =~ s/david/rules/r; |
| 17 | ok( $a eq 'rules', 's///r with constant' ); |
| 18 | |
| 19 | $a = "david" =~ s/david/"is"."great"/er; |
| 20 | ok( $a eq 'isgreat', 's///er' ); |
| 21 | |
| 22 | $a = "daviddavid" =~ s/david/cool/gr; |
| 23 | ok( $a eq 'coolcool', 's///gr' ); |
| 24 | |
| 25 | $a = 'david'; |
| 26 | $b = $a =~ s/david/sucks/r =~ s/sucks/rules/r; |
| 27 | ok( $a eq 'david' && $b eq 'rules', 'chained s///r' ); |
| 28 | |
| 29 | $a = 'david'; |
| 30 | $b = $a =~ s/xxx/sucks/r; |
| 31 | ok( $a eq 'david' && $b eq 'david', 'non matching s///r' ); |
| 32 | |
| 33 | $a = 'david'; |
| 34 | for (0..2) { |
| 35 | ok( 'david' =~ s/$a/rules/ro eq 'rules', 's///ro '.$_ ); |
| 36 | } |
| 37 | |
| 38 | $a = 'david'; |
| 39 | eval '$b = $a !~ s/david/is great/r'; |
| 40 | like( $@, qr{Using !~ with s///r doesn't make sense}, 's///r !~ operator gives error' ); |
| 41 | |
| 42 | { |
| 43 | no warnings 'uninitialized'; |
| 44 | $a = undef; |
| 45 | $b = $a =~ s/left/right/r; |
| 46 | ok ( !defined $a && !defined $b, 's///r with undef input' ); |
| 47 | |
| 48 | use warnings; |
| 49 | warning_like(sub { $b = $a =~ s/left/right/r }, |
| 50 | qr/^Use of uninitialized value/, |
| 51 | 's///r Uninitialized warning'); |
| 52 | |
| 53 | $a = 'david'; |
| 54 | warning_like(sub {eval 's/david/sucks/r; 1'}, |
| 55 | qr/^Useless use of non-destructive substitution/, |
| 56 | 's///r void context warning'); |
| 57 | } |
| 58 | |
| 59 | $a = ''; |
| 60 | $b = $a =~ s/david/rules/r; |
| 61 | ok( $a eq '' && $b eq '', 's///r on empty string' ); |
| 62 | |
| 63 | $_ = 'david'; |
| 64 | @b = s/david/rules/r; |
| 65 | ok( $_ eq 'david' && $b[0] eq 'rules', 's///r in list context' ); |
| 66 | |
| 67 | # Magic value and s///r |
| 68 | require Tie::Scalar; |
| 69 | tie $m, 'Tie::StdScalar'; # makes $a magical |
| 70 | $m = "david"; |
| 71 | $b = $m =~ s/david/rules/r; |
| 72 | ok( $m eq 'david' && $b eq 'rules', 's///r with magic input' ); |
| 73 | |
| 74 | $m = $b =~ s/rules/david/r; |
| 75 | ok( defined tied($m), 's///r magic isn\'t lost' ); |
| 76 | |
| 77 | $b = $m =~ s/xxx/yyy/r; |
| 78 | ok( ! defined tied($b), 's///r magic isn\'t contagious' ); |
| 79 | |
| 80 | my $ref = \("aaa" =~ s/aaa/bbb/r); |
| 81 | is (Internals::SvREFCNT($$ref), 1, 's///r does not leak'); |
| 82 | $ref = \("aaa" =~ s/aaa/bbb/rg); |
| 83 | is (Internals::SvREFCNT($$ref), 1, 's///rg does not leak'); |
| 84 | |
| 85 | $x = 'foo'; |
| 86 | $_ = "x"; |
| 87 | s/x/\$x/; |
| 88 | ok( $_ eq '$x', ":$_: eq :\$x:" ); |
| 89 | |
| 90 | $_ = "x"; |
| 91 | s/x/$x/; |
| 92 | ok( $_ eq 'foo', ":$_: eq :foo:" ); |
| 93 | |
| 94 | $_ = "x"; |
| 95 | s/x/\$x $x/; |
| 96 | ok( $_ eq '$x foo', ":$_: eq :\$x foo:" ); |
| 97 | |
| 98 | $b = 'cd'; |
| 99 | ($a = 'abcdef') =~ s<(b${b}e)>'\n$1'; |
| 100 | ok( $1 eq 'bcde' && $a eq 'a\n$1f', ":$1: eq :bcde: ; :$a: eq :a\\n\$1f:" ); |
| 101 | |
| 102 | $a = 'abacada'; |
| 103 | ok( ($a =~ s/a/x/g) == 4 && $a eq 'xbxcxdx' ); |
| 104 | |
| 105 | ok( ($a =~ s/a/y/g) == 0 && $a eq 'xbxcxdx' ); |
| 106 | |
| 107 | ok( ($a =~ s/b/y/g) == 1 && $a eq 'xyxcxdx' ); |
| 108 | |
| 109 | $_ = 'ABACADA'; |
| 110 | ok( /a/i && s///gi && $_ eq 'BCD' ); |
| 111 | |
| 112 | $_ = '\\' x 4; |
| 113 | ok( length($_) == 4 ); |
| 114 | $snum = s/\\/\\\\/g; |
| 115 | ok( $_ eq '\\' x 8 && $snum == 4 ); |
| 116 | |
| 117 | $_ = '\/' x 4; |
| 118 | ok( length($_) == 8 ); |
| 119 | $snum = s/\//\/\//g; |
| 120 | ok( $_ eq '\\//' x 4 && $snum == 4 ); |
| 121 | ok( length($_) == 12 ); |
| 122 | |
| 123 | $_ = 'aaaXXXXbbb'; |
| 124 | s/^a//; |
| 125 | ok( $_ eq 'aaXXXXbbb' ); |
| 126 | |
| 127 | $_ = 'aaaXXXXbbb'; |
| 128 | s/a//; |
| 129 | ok( $_ eq 'aaXXXXbbb' ); |
| 130 | |
| 131 | $_ = 'aaaXXXXbbb'; |
| 132 | s/^a/b/; |
| 133 | ok( $_ eq 'baaXXXXbbb' ); |
| 134 | |
| 135 | $_ = 'aaaXXXXbbb'; |
| 136 | s/a/b/; |
| 137 | ok( $_ eq 'baaXXXXbbb' ); |
| 138 | |
| 139 | $_ = 'aaaXXXXbbb'; |
| 140 | s/aa//; |
| 141 | ok( $_ eq 'aXXXXbbb' ); |
| 142 | |
| 143 | $_ = 'aaaXXXXbbb'; |
| 144 | s/aa/b/; |
| 145 | ok( $_ eq 'baXXXXbbb' ); |
| 146 | |
| 147 | $_ = 'aaaXXXXbbb'; |
| 148 | s/b$//; |
| 149 | ok( $_ eq 'aaaXXXXbb' ); |
| 150 | |
| 151 | $_ = 'aaaXXXXbbb'; |
| 152 | s/b//; |
| 153 | ok( $_ eq 'aaaXXXXbb' ); |
| 154 | |
| 155 | $_ = 'aaaXXXXbbb'; |
| 156 | s/bb//; |
| 157 | ok( $_ eq 'aaaXXXXb' ); |
| 158 | |
| 159 | $_ = 'aaaXXXXbbb'; |
| 160 | s/aX/y/; |
| 161 | ok( $_ eq 'aayXXXbbb' ); |
| 162 | |
| 163 | $_ = 'aaaXXXXbbb'; |
| 164 | s/Xb/z/; |
| 165 | ok( $_ eq 'aaaXXXzbb' ); |
| 166 | |
| 167 | $_ = 'aaaXXXXbbb'; |
| 168 | s/aaX.*Xbb//; |
| 169 | ok( $_ eq 'ab' ); |
| 170 | |
| 171 | $_ = 'aaaXXXXbbb'; |
| 172 | s/bb/x/; |
| 173 | ok( $_ eq 'aaaXXXXxb' ); |
| 174 | |
| 175 | # now for some unoptimized versions of the same. |
| 176 | |
| 177 | $_ = 'aaaXXXXbbb'; |
| 178 | $x ne $x || s/^a//; |
| 179 | ok( $_ eq 'aaXXXXbbb' ); |
| 180 | |
| 181 | $_ = 'aaaXXXXbbb'; |
| 182 | $x ne $x || s/a//; |
| 183 | ok( $_ eq 'aaXXXXbbb' ); |
| 184 | |
| 185 | $_ = 'aaaXXXXbbb'; |
| 186 | $x ne $x || s/^a/b/; |
| 187 | ok( $_ eq 'baaXXXXbbb' ); |
| 188 | |
| 189 | $_ = 'aaaXXXXbbb'; |
| 190 | $x ne $x || s/a/b/; |
| 191 | ok( $_ eq 'baaXXXXbbb' ); |
| 192 | |
| 193 | $_ = 'aaaXXXXbbb'; |
| 194 | $x ne $x || s/aa//; |
| 195 | ok( $_ eq 'aXXXXbbb' ); |
| 196 | |
| 197 | $_ = 'aaaXXXXbbb'; |
| 198 | $x ne $x || s/aa/b/; |
| 199 | ok( $_ eq 'baXXXXbbb' ); |
| 200 | |
| 201 | $_ = 'aaaXXXXbbb'; |
| 202 | $x ne $x || s/b$//; |
| 203 | ok( $_ eq 'aaaXXXXbb' ); |
| 204 | |
| 205 | $_ = 'aaaXXXXbbb'; |
| 206 | $x ne $x || s/b//; |
| 207 | ok( $_ eq 'aaaXXXXbb' ); |
| 208 | |
| 209 | $_ = 'aaaXXXXbbb'; |
| 210 | $x ne $x || s/bb//; |
| 211 | ok( $_ eq 'aaaXXXXb' ); |
| 212 | |
| 213 | $_ = 'aaaXXXXbbb'; |
| 214 | $x ne $x || s/aX/y/; |
| 215 | ok( $_ eq 'aayXXXbbb' ); |
| 216 | |
| 217 | $_ = 'aaaXXXXbbb'; |
| 218 | $x ne $x || s/Xb/z/; |
| 219 | ok( $_ eq 'aaaXXXzbb' ); |
| 220 | |
| 221 | $_ = 'aaaXXXXbbb'; |
| 222 | $x ne $x || s/aaX.*Xbb//; |
| 223 | ok( $_ eq 'ab' ); |
| 224 | |
| 225 | $_ = 'aaaXXXXbbb'; |
| 226 | $x ne $x || s/bb/x/; |
| 227 | ok( $_ eq 'aaaXXXXxb' ); |
| 228 | |
| 229 | $_ = 'abc123xyz'; |
| 230 | s/(\d+)/$1*2/e; # yields 'abc246xyz' |
| 231 | ok( $_ eq 'abc246xyz' ); |
| 232 | s/(\d+)/sprintf("%5d",$1)/e; # yields 'abc 246xyz' |
| 233 | ok( $_ eq 'abc 246xyz' ); |
| 234 | s/(\w)/$1 x 2/eg; # yields 'aabbcc 224466xxyyzz' |
| 235 | ok( $_ eq 'aabbcc 224466xxyyzz' ); |
| 236 | |
| 237 | $_ = "aaaaa"; |
| 238 | ok( y/a/b/ == 5 ); |
| 239 | ok( y/a/b/ == 0 ); |
| 240 | ok( y/b// == 5 ); |
| 241 | ok( y/b/c/s == 5 ); |
| 242 | ok( y/c// == 1 ); |
| 243 | ok( y/c//d == 1 ); |
| 244 | ok( $_ eq "" ); |
| 245 | |
| 246 | $_ = "Now is the %#*! time for all good men..."; |
| 247 | ok( ($x=(y/a-zA-Z //cd)) == 7 ); |
| 248 | ok( y/ / /s == 8 ); |
| 249 | |
| 250 | $_ = 'abcdefghijklmnopqrstuvwxyz0123456789'; |
| 251 | tr/a-z/A-Z/; |
| 252 | |
| 253 | ok( $_ eq 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789' ); |
| 254 | |
| 255 | # same as tr/A-Z/a-z/; |
| 256 | if (defined $Config{ebcdic} && $Config{ebcdic} eq 'define') { # EBCDIC. |
| 257 | no utf8; |
| 258 | y[\301-\351][\201-\251]; |
| 259 | } else { # Ye Olde ASCII. Or something like it. |
| 260 | y[\101-\132][\141-\172]; |
| 261 | } |
| 262 | |
| 263 | ok( $_ eq 'abcdefghijklmnopqrstuvwxyz0123456789' ); |
| 264 | |
| 265 | SKIP: { |
| 266 | skip("not ASCII",1) unless (ord("+") == ord(",") - 1 |
| 267 | && ord(",") == ord("-") - 1 |
| 268 | && ord("a") == ord("b") - 1 |
| 269 | && ord("b") == ord("c") - 1); |
| 270 | $_ = '+,-'; |
| 271 | tr/+--/a-c/; |
| 272 | ok( $_ eq 'abc' ); |
| 273 | } |
| 274 | |
| 275 | $_ = '+,-'; |
| 276 | tr/+\--/a\/c/; |
| 277 | ok( $_ eq 'a,/' ); |
| 278 | |
| 279 | $_ = '+,-'; |
| 280 | tr/-+,/ab\-/; |
| 281 | ok( $_ eq 'b-a' ); |
| 282 | |
| 283 | |
| 284 | # test recursive substitutions |
| 285 | # code based on the recursive expansion of makefile variables |
| 286 | |
| 287 | my %MK = ( |
| 288 | AAAAA => '$(B)', B=>'$(C)', C => 'D', # long->short |
| 289 | E => '$(F)', F=>'p $(G) q', G => 'HHHHH', # short->long |
| 290 | DIR => '$(UNDEFINEDNAME)/xxx', |
| 291 | ); |
| 292 | sub var { |
| 293 | my($var,$level) = @_; |
| 294 | return "\$($var)" unless exists $MK{$var}; |
| 295 | return exp_vars($MK{$var}, $level+1); # can recurse |
| 296 | } |
| 297 | sub exp_vars { |
| 298 | my($str,$level) = @_; |
| 299 | $str =~ s/\$\((\w+)\)/var($1, $level+1)/ge; # can recurse |
| 300 | #warn "exp_vars $level = '$str'\n"; |
| 301 | $str; |
| 302 | } |
| 303 | |
| 304 | ok( exp_vars('$(AAAAA)',0) eq 'D' ); |
| 305 | ok( exp_vars('$(E)',0) eq 'p HHHHH q' ); |
| 306 | ok( exp_vars('$(DIR)',0) eq '$(UNDEFINEDNAME)/xxx' ); |
| 307 | ok( exp_vars('foo $(DIR)/yyy bar',0) eq 'foo $(UNDEFINEDNAME)/xxx/yyy bar' ); |
| 308 | |
| 309 | $_ = "abcd"; |
| 310 | s/(..)/$x = $1, m#.#/eg; |
| 311 | ok( $x eq "cd", 'a match nested in the RHS of a substitution' ); |
| 312 | |
| 313 | # Subst and lookbehind |
| 314 | |
| 315 | $_="ccccc"; |
| 316 | $snum = s/(?<!x)c/x/g; |
| 317 | ok( $_ eq "xxxxx" && $snum == 5 ); |
| 318 | |
| 319 | $_="ccccc"; |
| 320 | $snum = s/(?<!x)(c)/x/g; |
| 321 | ok( $_ eq "xxxxx" && $snum == 5 ); |
| 322 | |
| 323 | $_="foobbarfoobbar"; |
| 324 | $snum = s/(?<!r)foobbar/foobar/g; |
| 325 | ok( $_ eq "foobarfoobbar" && $snum == 1 ); |
| 326 | |
| 327 | $_="foobbarfoobbar"; |
| 328 | $snum = s/(?<!ar)(foobbar)/foobar/g; |
| 329 | ok( $_ eq "foobarfoobbar" && $snum == 1 ); |
| 330 | |
| 331 | $_="foobbarfoobbar"; |
| 332 | $snum = s/(?<!ar)foobbar/foobar/g; |
| 333 | ok( $_ eq "foobarfoobbar" && $snum == 1 ); |
| 334 | |
| 335 | eval 's{foo} # this is a comment, not a delimiter |
| 336 | {bar};'; |
| 337 | ok( ! @?, 'parsing of split subst with comment' ); |
| 338 | |
| 339 | $snum = eval '$_="exactly"; s sxsys;m 3(yactl)3;$1'; |
| 340 | is( $snum, 'yactl', 'alpha delimiters are allowed' ); |
| 341 | |
| 342 | $_="baacbaa"; |
| 343 | $snum = tr/a/b/s; |
| 344 | ok( $_ eq "bbcbb" && $snum == 4, |
| 345 | 'check if squashing works at the end of string' ); |
| 346 | |
| 347 | $_ = "ab"; |
| 348 | ok( s/a/b/ == 1 ); |
| 349 | |
| 350 | $_ = <<'EOL'; |
| 351 | $url = new URI::URL "http://www/"; die if $url eq "xXx"; |
| 352 | EOL |
| 353 | $^R = 'junk'; |
| 354 | |
| 355 | $foo = ' $@%#lowercase $@%# lowercase UPPERCASE$@%#UPPERCASE' . |
| 356 | ' $@%#lowercase$@%#lowercase$@%# lowercase lowercase $@%#lowercase' . |
| 357 | ' lowercase $@%#MiXeD$@%# '; |
| 358 | |
| 359 | $snum = |
| 360 | s{ \d+ \b [,.;]? (?{ 'digits' }) |
| 361 | | |
| 362 | [a-z]+ \b [,.;]? (?{ 'lowercase' }) |
| 363 | | |
| 364 | [A-Z]+ \b [,.;]? (?{ 'UPPERCASE' }) |
| 365 | | |
| 366 | [A-Z] [a-z]+ \b [,.;]? (?{ 'Capitalized' }) |
| 367 | | |
| 368 | [A-Za-z]+ \b [,.;]? (?{ 'MiXeD' }) |
| 369 | | |
| 370 | [A-Za-z0-9]+ \b [,.;]? (?{ 'alphanumeric' }) |
| 371 | | |
| 372 | \s+ (?{ ' ' }) |
| 373 | | |
| 374 | [^A-Za-z0-9\s]+ (?{ '$@%#' }) |
| 375 | }{$^R}xg; |
| 376 | ok( $_ eq $foo ); |
| 377 | ok( $snum == 31 ); |
| 378 | |
| 379 | $_ = 'a' x 6; |
| 380 | $snum = s/a(?{})//g; |
| 381 | ok( $_ eq '' && $snum == 6 ); |
| 382 | |
| 383 | $_ = 'x' x 20; |
| 384 | $snum = s/(\d*|x)/<$1>/g; |
| 385 | $foo = '<>' . ('<x><>' x 20) ; |
| 386 | ok( $_ eq $foo && $snum == 41 ); |
| 387 | |
| 388 | $t = 'aaaaaaaaa'; |
| 389 | |
| 390 | $_ = $t; |
| 391 | pos = 6; |
| 392 | $snum = s/\Ga/xx/g; |
| 393 | ok( $_ eq 'aaaaaaxxxxxx' && $snum == 3 ); |
| 394 | |
| 395 | $_ = $t; |
| 396 | pos = 6; |
| 397 | $snum = s/\Ga/x/g; |
| 398 | ok( $_ eq 'aaaaaaxxx' && $snum == 3 ); |
| 399 | |
| 400 | $_ = $t; |
| 401 | pos = 6; |
| 402 | s/\Ga/xx/; |
| 403 | ok( $_ eq 'aaaaaaxxaa' ); |
| 404 | |
| 405 | $_ = $t; |
| 406 | pos = 6; |
| 407 | s/\Ga/x/; |
| 408 | ok( $_ eq 'aaaaaaxaa' ); |
| 409 | |
| 410 | $_ = $t; |
| 411 | $snum = s/\Ga/xx/g; |
| 412 | ok( $_ eq 'xxxxxxxxxxxxxxxxxx' && $snum == 9 ); |
| 413 | |
| 414 | $_ = $t; |
| 415 | $snum = s/\Ga/x/g; |
| 416 | ok( $_ eq 'xxxxxxxxx' && $snum == 9 ); |
| 417 | |
| 418 | $_ = $t; |
| 419 | s/\Ga/xx/; |
| 420 | ok( $_ eq 'xxaaaaaaaa' ); |
| 421 | |
| 422 | $_ = $t; |
| 423 | s/\Ga/x/; |
| 424 | ok( $_ eq 'xaaaaaaaa' ); |
| 425 | |
| 426 | $_ = 'aaaa'; |
| 427 | $snum = s/\ba/./g; |
| 428 | ok( $_ eq '.aaa' && $snum == 1 ); |
| 429 | |
| 430 | eval q% s/a/"b"}/e %; |
| 431 | ok( $@ =~ /Bad evalled substitution/ ); |
| 432 | eval q% ($_ = "x") =~ s/(.)/"$1 "/e %; |
| 433 | ok( $_ eq "x " and !length $@ ); |
| 434 | $x = $x = 'interp'; |
| 435 | eval q% ($_ = "x") =~ s/x(($x)*)/"$1"/e %; |
| 436 | ok( $_ eq '' and !length $@ ); |
| 437 | |
| 438 | $_ = "C:/"; |
| 439 | ok( !s/^([a-z]:)/\u$1/ ); |
| 440 | |
| 441 | $_ = "Charles Bronson"; |
| 442 | $snum = s/\B\w//g; |
| 443 | ok( $_ eq "C B" && $snum == 12 ); |
| 444 | |
| 445 | { |
| 446 | use utf8; |
| 447 | my $s = "H\303\266he"; |
| 448 | my $l = my $r = $s; |
| 449 | $l =~ s/[^\w]//g; |
| 450 | $r =~ s/[^\w\.]//g; |
| 451 | is($l, $r, "use utf8 \\w"); |
| 452 | } |
| 453 | |
| 454 | my $pv1 = my $pv2 = "Andreas J. K\303\266nig"; |
| 455 | $pv1 =~ s/A/\x{100}/; |
| 456 | substr($pv2,0,1) = "\x{100}"; |
| 457 | is($pv1, $pv2); |
| 458 | |
| 459 | SKIP: { |
| 460 | skip("EBCDIC", 3) if ord("A") == 193; |
| 461 | |
| 462 | { |
| 463 | # Gregor Chrupala <gregor.chrupala@star-group.net> |
| 464 | use utf8; |
| 465 | $a = 'España'; |
| 466 | $a =~ s/ñ/ñ/; |
| 467 | like($a, qr/ñ/, "use utf8 RHS"); |
| 468 | } |
| 469 | |
| 470 | { |
| 471 | use utf8; |
| 472 | $a = 'España España'; |
| 473 | $a =~ s/ñ/ñ/; |
| 474 | like($a, qr/ñ/, "use utf8 LHS"); |
| 475 | } |
| 476 | |
| 477 | { |
| 478 | use utf8; |
| 479 | $a = 'España'; |
| 480 | $a =~ s/ñ/ñ/; |
| 481 | like($a, qr/ñ/, "use utf8 LHS and RHS"); |
| 482 | } |
| 483 | } |
| 484 | |
| 485 | { |
| 486 | # SADAHIRO Tomoyuki <bqw10602@nifty.com> |
| 487 | |
| 488 | $a = "\x{100}\x{101}"; |
| 489 | $a =~ s/\x{101}/\xFF/; |
| 490 | like($a, qr/\xFF/); |
| 491 | is(length($a), 2, "SADAHIRO utf8 s///"); |
| 492 | |
| 493 | $a = "\x{100}\x{101}"; |
| 494 | $a =~ s/\x{101}/"\xFF"/e; |
| 495 | like($a, qr/\xFF/); |
| 496 | is(length($a), 2); |
| 497 | |
| 498 | $a = "\x{100}\x{101}"; |
| 499 | $a =~ s/\x{101}/\xFF\xFF\xFF/; |
| 500 | like($a, qr/\xFF\xFF\xFF/); |
| 501 | is(length($a), 4); |
| 502 | |
| 503 | $a = "\x{100}\x{101}"; |
| 504 | $a =~ s/\x{101}/"\xFF\xFF\xFF"/e; |
| 505 | like($a, qr/\xFF\xFF\xFF/); |
| 506 | is(length($a), 4); |
| 507 | |
| 508 | $a = "\xFF\x{101}"; |
| 509 | $a =~ s/\xFF/\x{100}/; |
| 510 | like($a, qr/\x{100}/); |
| 511 | is(length($a), 2); |
| 512 | |
| 513 | $a = "\xFF\x{101}"; |
| 514 | $a =~ s/\xFF/"\x{100}"/e; |
| 515 | like($a, qr/\x{100}/); |
| 516 | is(length($a), 2); |
| 517 | |
| 518 | $a = "\xFF"; |
| 519 | $a =~ s/\xFF/\x{100}/; |
| 520 | like($a, qr/\x{100}/); |
| 521 | is(length($a), 1); |
| 522 | |
| 523 | $a = "\xFF"; |
| 524 | $a =~ s/\xFF/"\x{100}"/e; |
| 525 | like($a, qr/\x{100}/); |
| 526 | is(length($a), 1); |
| 527 | } |
| 528 | |
| 529 | { |
| 530 | # subst with mixed utf8/non-utf8 type |
| 531 | my($ua, $ub, $uc, $ud) = ("\x{101}", "\x{102}", "\x{103}", "\x{104}"); |
| 532 | my($na, $nb) = ("\x{ff}", "\x{fe}"); |
| 533 | my $a = "$ua--$ub"; |
| 534 | my $b; |
| 535 | ($b = $a) =~ s/--/$na/; |
| 536 | is($b, "$ua$na$ub", "s///: replace non-utf8 into utf8"); |
| 537 | ($b = $a) =~ s/--/--$na--/; |
| 538 | is($b, "$ua--$na--$ub", "s///: replace long non-utf8 into utf8"); |
| 539 | ($b = $a) =~ s/--/$uc/; |
| 540 | is($b, "$ua$uc$ub", "s///: replace utf8 into utf8"); |
| 541 | ($b = $a) =~ s/--/--$uc--/; |
| 542 | is($b, "$ua--$uc--$ub", "s///: replace long utf8 into utf8"); |
| 543 | $a = "$na--$nb"; |
| 544 | ($b = $a) =~ s/--/$ua/; |
| 545 | is($b, "$na$ua$nb", "s///: replace utf8 into non-utf8"); |
| 546 | ($b = $a) =~ s/--/--$ua--/; |
| 547 | is($b, "$na--$ua--$nb", "s///: replace long utf8 into non-utf8"); |
| 548 | |
| 549 | # now with utf8 pattern |
| 550 | $a = "$ua--$ub"; |
| 551 | ($b = $a) =~ s/-($ud)?-/$na/; |
| 552 | is($b, "$ua$na$ub", "s///: replace non-utf8 into utf8 (utf8 pattern)"); |
| 553 | ($b = $a) =~ s/-($ud)?-/--$na--/; |
| 554 | is($b, "$ua--$na--$ub", "s///: replace long non-utf8 into utf8 (utf8 pattern)"); |
| 555 | ($b = $a) =~ s/-($ud)?-/$uc/; |
| 556 | is($b, "$ua$uc$ub", "s///: replace utf8 into utf8 (utf8 pattern)"); |
| 557 | ($b = $a) =~ s/-($ud)?-/--$uc--/; |
| 558 | is($b, "$ua--$uc--$ub", "s///: replace long utf8 into utf8 (utf8 pattern)"); |
| 559 | $a = "$na--$nb"; |
| 560 | ($b = $a) =~ s/-($ud)?-/$ua/; |
| 561 | is($b, "$na$ua$nb", "s///: replace utf8 into non-utf8 (utf8 pattern)"); |
| 562 | ($b = $a) =~ s/-($ud)?-/--$ua--/; |
| 563 | is($b, "$na--$ua--$nb", "s///: replace long utf8 into non-utf8 (utf8 pattern)"); |
| 564 | ($b = $a) =~ s/-($ud)?-/$na/; |
| 565 | is($b, "$na$na$nb", "s///: replace non-utf8 into non-utf8 (utf8 pattern)"); |
| 566 | ($b = $a) =~ s/-($ud)?-/--$na--/; |
| 567 | is($b, "$na--$na--$nb", "s///: replace long non-utf8 into non-utf8 (utf8 pattern)"); |
| 568 | } |
| 569 | |
| 570 | $_ = 'aaaa'; |
| 571 | $r = 'x'; |
| 572 | $s = s/a(?{})/$r/g; |
| 573 | is("<$_> <$s>", "<xxxx> <4>", "[perl #7806]"); |
| 574 | |
| 575 | $_ = 'aaaa'; |
| 576 | $s = s/a(?{})//g; |
| 577 | is("<$_> <$s>", "<> <4>", "[perl #7806]"); |
| 578 | |
| 579 | # [perl #19048] Coredump in silly replacement |
| 580 | { |
| 581 | local $^W = 0; |
| 582 | $_="abcdef\n"; |
| 583 | s!.!!eg; |
| 584 | is($_, "\n", "[perl #19048]"); |
| 585 | } |
| 586 | |
| 587 | # [perl #17757] interaction between saw_ampersand and study |
| 588 | { |
| 589 | my $f = eval q{ $& }; |
| 590 | $f = "xx"; |
| 591 | study $f; |
| 592 | $f =~ s/x/y/g; |
| 593 | is($f, "yy", "[perl #17757]"); |
| 594 | } |
| 595 | |
| 596 | # [perl #20684] returned a zero count |
| 597 | $_ = "1111"; |
| 598 | is(s/(??{1})/2/eg, 4, '#20684 s/// with (??{..}) inside'); |
| 599 | |
| 600 | # [perl #20682] @- not visible in replacement |
| 601 | $_ = "123"; |
| 602 | /(2)/; # seed @- with something else |
| 603 | s/(1)(2)(3)/$#- (@-)/; |
| 604 | is($_, "3 (0 0 1 2)", '#20682 @- not visible in replacement'); |
| 605 | |
| 606 | # [perl #20682] $^N not visible in replacement |
| 607 | $_ = "abc"; |
| 608 | /(a)/; s/(b)|(c)/-$^N/g; |
| 609 | is($_,'a-b-c','#20682 $^N not visible in replacement'); |
| 610 | |
| 611 | # [perl #22351] perl bug with 'e' substitution modifier |
| 612 | my $name = "chris"; |
| 613 | { |
| 614 | no warnings 'uninitialized'; |
| 615 | $name =~ s/hr//e; |
| 616 | } |
| 617 | is($name, "cis", q[#22351 bug with 'e' substitution modifier]); |
| 618 | |
| 619 | |
| 620 | # [perl #34171] $1 didn't honour 'use bytes' in s//e |
| 621 | { |
| 622 | my $s="\x{100}"; |
| 623 | my $x; |
| 624 | { |
| 625 | use bytes; |
| 626 | $s=~ s/(..)/$x=$1/e |
| 627 | } |
| 628 | is(length($x), 2, '[perl #34171]'); |
| 629 | } |
| 630 | |
| 631 | |
| 632 | { # [perl #27940] perlbug: [\x00-\x1f] works, [\c@-\c_] does not |
| 633 | my $c; |
| 634 | |
| 635 | ($c = "\x20\c@\x30\cA\x40\cZ\x50\c_\x60") =~ s/[\c@-\c_]//g; |
| 636 | is($c, "\x20\x30\x40\x50\x60", "s/[\\c\@-\\c_]//g"); |
| 637 | |
| 638 | ($c = "\x20\x00\x30\x01\x40\x1A\x50\x1F\x60") =~ s/[\x00-\x1f]//g; |
| 639 | is($c, "\x20\x30\x40\x50\x60", "s/[\\x00-\\x1f]//g"); |
| 640 | } |
| 641 | { |
| 642 | $_ = "xy"; |
| 643 | no warnings 'uninitialized'; |
| 644 | /(((((((((x)))))))))(z)/; # clear $10 |
| 645 | s/(((((((((x)))))))))(y)/${10}/; |
| 646 | is($_,"y","RT#6006: \$_ eq '$_'"); |
| 647 | $_ = "xr"; |
| 648 | s/(((((((((x)))))))))(r)/fooba${10}/; |
| 649 | is($_,"foobar","RT#6006: \$_ eq '$_'"); |
| 650 | } |
| 651 | { |
| 652 | my $want=("\n" x 11).("B\n" x 11)."B"; |
| 653 | $_="B"; |
| 654 | our $i; |
| 655 | for $i(1..11){ |
| 656 | s/^.*$/$&/gm; |
| 657 | $_="\n$_\n$&"; |
| 658 | } |
| 659 | is($want,$_,"RT#17542"); |
| 660 | } |
| 661 | |
| 662 | { |
| 663 | my @tests = ('ABC', "\xA3\xA4\xA5", "\x{410}\x{411}\x{412}"); |
| 664 | foreach (@tests) { |
| 665 | my $id = ord $_; |
| 666 | s/./pos/ge; |
| 667 | is($_, "012", "RT#52104: $id"); |
| 668 | } |
| 669 | } |
| 670 | |
| 671 | fresh_perl_is( '$_=q(foo);s/(.)\G//g;print' => 'foo', '[perl #69056] positive GPOS regex segfault' ); |
| 672 | fresh_perl_is( '$_="abcef"; s/bc|(.)\G(.)/$1 ? "[$1-$2]" : "XX"/ge; print' => 'aXX[c-e][e-f]f', 'positive GPOS regex substitution failure' ); |
| 673 | |
| 674 | # [perl #71470] $var =~ s/$qr//e calling get-magic on $_ as well as $var |
| 675 | { |
| 676 | local *_; |
| 677 | my $scratch; |
| 678 | sub qrBug::TIESCALAR { bless[pop], 'qrBug' } |
| 679 | sub qrBug::FETCH { $scratch .= "[fetching $_[0][0]]"; 'prew' } |
| 680 | sub qrBug::STORE{} |
| 681 | tie my $kror, qrBug => '$kror'; |
| 682 | tie $_, qrBug => '$_'; |
| 683 | my $qr = qr/(?:)/; |
| 684 | $kror =~ s/$qr/""/e; |
| 685 | is( |
| 686 | $scratch, '[fetching $kror]', |
| 687 | 'bug: $var =~ s/$qr//e calling get-magic on $_ as well as $var', |
| 688 | ); |
| 689 | } |
| 690 | |
| 691 | { # Bug #41530; replacing non-utf8 with a utf8 causes problems |
| 692 | my $string = "a\x{a0}a"; |
| 693 | my $sub_string = $string; |
| 694 | ok(! utf8::is_utf8($sub_string), "Verify that string isn't initially utf8"); |
| 695 | $sub_string =~ s/a/\x{100}/g; |
| 696 | ok(utf8::is_utf8($sub_string), |
| 697 | 'Verify replace of non-utf8 with utf8 upgrades to utf8'); |
| 698 | is($sub_string, "\x{100}\x{A0}\x{100}", |
| 699 | 'Verify #41530 fixed: replace of non-utf8 with utf8'); |
| 700 | |
| 701 | my $non_sub_string = $string; |
| 702 | ok(! utf8::is_utf8($non_sub_string), |
| 703 | "Verify that string isn't initially utf8"); |
| 704 | $non_sub_string =~ s/b/\x{100}/g; |
| 705 | ok(! utf8::is_utf8($non_sub_string), |
| 706 | "Verify that failed substitute doesn't change string's utf8ness"); |
| 707 | is($non_sub_string, $string, |
| 708 | "Verify that failed substitute doesn't change string"); |
| 709 | } |
| 710 | |
| 711 | { # Verify largish octal in replacement pattern |
| 712 | |
| 713 | my $string = "a"; |
| 714 | $string =~ s/a/\400/; |
| 715 | is($string, chr 0x100, "Verify that handles s/foo/\\400/"); |
| 716 | $string =~ s/./\600/; |
| 717 | is($string, chr 0x180, "Verify that handles s/foo/\\600/"); |
| 718 | $string =~ s/./\777/; |
| 719 | is($string, chr 0x1FF, "Verify that handles s/foo/\\777/"); |
| 720 | } |
| 721 | |
| 722 | # Scoping of s//the RHS/ when there is no /e |
| 723 | # Tests based on [perl #19078] |
| 724 | { |
| 725 | local *_; |
| 726 | my $output = ''; my %a; |
| 727 | no warnings 'uninitialized'; |
| 728 | |
| 729 | $_="CCCGGG"; |
| 730 | s!.!<@a{$output .= ("$&"),/[$&]/g}>!g; |
| 731 | $output .= $_; |
| 732 | is( |
| 733 | $output, "CCCGGG< >< >< >< >< >< >", |
| 734 | 's/// sets PL_curpm for each iteration even when the RHS has set it' |
| 735 | ); |
| 736 | |
| 737 | s/C/$a{m\G\}/; |
| 738 | is( |
| 739 | "$&", G => |
| 740 | 'Match vars reflect the last match after s/pat/$a{m|pat|}/ without /e' |
| 741 | ); |
| 742 | } |
| 743 | |
| 744 | { |
| 745 | # a tied scalar that returned a plain string, got messed up |
| 746 | # when substituted with a UTF8 replacement string, due to |
| 747 | # magic getting called multiple times, and pointers now pointing |
| 748 | # to stale/freed strings |
| 749 | package FOO; |
| 750 | my $fc; |
| 751 | sub TIESCALAR { bless [ "abcdefgh" ] } |
| 752 | sub FETCH { $fc++; $_[0][0] } |
| 753 | sub STORE { $_[0][0] = $_[1] } |
| 754 | |
| 755 | my $s; |
| 756 | tie $s, 'FOO'; |
| 757 | $s =~ s/..../\x{101}/; |
| 758 | ::is($fc, 1, "tied UTF8 stuff FETCH count"); |
| 759 | ::is("$s", "\x{101}efgh", "tied UTF8 stuff"); |
| 760 | } |