| 1 | #!./perl |
| 2 | |
| 3 | #P = start of string Q = start of substr R = end of substr S = end of string |
| 4 | |
| 5 | BEGIN { |
| 6 | chdir 't' if -d 't'; |
| 7 | require './test.pl'; |
| 8 | set_up_inc('../lib'); |
| 9 | } |
| 10 | use warnings ; |
| 11 | |
| 12 | $a = 'abcdefxyz'; |
| 13 | $SIG{__WARN__} = sub { |
| 14 | if ($_[0] =~ /^substr outside of string/) { |
| 15 | $w++; |
| 16 | } elsif ($_[0] =~ /^Attempt to use reference as lvalue in substr/) { |
| 17 | $w += 2; |
| 18 | } elsif ($_[0] =~ /^Use of uninitialized value/) { |
| 19 | $w += 3; |
| 20 | } else { |
| 21 | warn $_[0]; |
| 22 | } |
| 23 | }; |
| 24 | |
| 25 | plan(400); |
| 26 | |
| 27 | run_tests() unless caller; |
| 28 | |
| 29 | my $krunch = "a"; |
| 30 | |
| 31 | sub run_tests { |
| 32 | |
| 33 | $FATAL_MSG = qr/^substr outside of string/; |
| 34 | |
| 35 | is(substr($a,0,3), 'abc'); # P=Q R S |
| 36 | is(substr($a,3,3), 'def'); # P Q R S |
| 37 | is(substr($a,6,999), 'xyz'); # P Q S R |
| 38 | $b = substr($a,999,999) ; # warn # P R Q S |
| 39 | is ($w--, 1); |
| 40 | eval{substr($a,999,999) = "" ; };# P R Q S |
| 41 | like ($@, $FATAL_MSG); |
| 42 | is(substr($a,0,-6), 'abc'); # P=Q R S |
| 43 | is(substr($a,-3,1), 'x'); # P Q R S |
| 44 | sub{$b = shift}->(substr($a,999,999)); |
| 45 | is ($w--, 1, 'boundless lvalue substr only warns on fetch'); |
| 46 | |
| 47 | substr($a,3,3) = 'XYZ'; |
| 48 | is($a, 'abcXYZxyz' ); |
| 49 | substr($a,0,2) = ''; |
| 50 | is($a, 'cXYZxyz' ); |
| 51 | substr($a,0,0) = 'ab'; |
| 52 | is($a, 'abcXYZxyz' ); |
| 53 | substr($a,0,0) = '12345678'; |
| 54 | is($a, '12345678abcXYZxyz' ); |
| 55 | substr($a,-3,3) = 'def'; |
| 56 | is($a, '12345678abcXYZdef'); |
| 57 | substr($a,-3,3) = '<'; |
| 58 | is($a, '12345678abcXYZ<' ); |
| 59 | substr($a,-1,1) = '12345678'; |
| 60 | is($a, '12345678abcXYZ12345678' ); |
| 61 | |
| 62 | $a = 'abcdefxyz'; |
| 63 | |
| 64 | is(substr($a,6), 'xyz' ); # P Q R=S |
| 65 | is(substr($a,-3), 'xyz' ); # P Q R=S |
| 66 | $b = substr($a,999,999) ; # warning # P R=S Q |
| 67 | is($w--, 1); |
| 68 | eval{substr($a,999,999) = "" ; } ; # P R=S Q |
| 69 | like($@, $FATAL_MSG); |
| 70 | is(substr($a,0), 'abcdefxyz'); # P=Q R=S |
| 71 | is(substr($a,9), ''); # P Q=R=S |
| 72 | is(substr($a,-11), 'abcdefxyz'); # Q P R=S |
| 73 | is(substr($a,-9), 'abcdefxyz'); # P=Q R=S |
| 74 | |
| 75 | $a = '54321'; |
| 76 | |
| 77 | $b = substr($a,-7, 1) ; # warn # Q R P S |
| 78 | is($w--, 1); |
| 79 | eval{substr($a,-7, 1) = "" ; }; # Q R P S |
| 80 | like($@, $FATAL_MSG); |
| 81 | $b = substr($a,-7,-6) ; # warn # Q R P S |
| 82 | is($w--, 1); |
| 83 | eval{substr($a,-7,-6) = "" ; }; # Q R P S |
| 84 | like($@, $FATAL_MSG); |
| 85 | is(substr($a,-5,-7), ''); # R P=Q S |
| 86 | is(substr($a, 2,-7), ''); # R P Q S |
| 87 | is(substr($a,-3,-7), ''); # R P Q S |
| 88 | is(substr($a, 2,-5), ''); # P=R Q S |
| 89 | is(substr($a,-3,-5), ''); # P=R Q S |
| 90 | is(substr($a, 2,-4), ''); # P R Q S |
| 91 | is(substr($a,-3,-4), ''); # P R Q S |
| 92 | is(substr($a, 5,-6), ''); # R P Q=S |
| 93 | is(substr($a, 5,-5), ''); # P=R Q S |
| 94 | is(substr($a, 5,-3), ''); # P R Q=S |
| 95 | $b = substr($a, 7,-7) ; # warn # R P S Q |
| 96 | is($w--, 1); |
| 97 | eval{substr($a, 7,-7) = "" ; }; # R P S Q |
| 98 | like($@, $FATAL_MSG); |
| 99 | $b = substr($a, 7,-5) ; # warn # P=R S Q |
| 100 | is($w--, 1); |
| 101 | eval{substr($a, 7,-5) = "" ; }; # P=R S Q |
| 102 | like($@, $FATAL_MSG); |
| 103 | $b = substr($a, 7,-3) ; # warn # P Q S Q |
| 104 | is($w--, 1); |
| 105 | eval{substr($a, 7,-3) = "" ; }; # P Q S Q |
| 106 | like($@, $FATAL_MSG); |
| 107 | $b = substr($a, 7, 0) ; # warn # P S Q=R |
| 108 | is($w--, 1); |
| 109 | eval{substr($a, 7, 0) = "" ; }; # P S Q=R |
| 110 | like($@, $FATAL_MSG); |
| 111 | |
| 112 | is(substr($a,-7,2), ''); # Q P=R S |
| 113 | is(substr($a,-7,4), '54'); # Q P R S |
| 114 | is(substr($a,-7,7), '54321');# Q P R=S |
| 115 | is(substr($a,-7,9), '54321');# Q P S R |
| 116 | is(substr($a,-5,0), ''); # P=Q=R S |
| 117 | is(substr($a,-5,3), '543');# P=Q R S |
| 118 | is(substr($a,-5,5), '54321');# P=Q R=S |
| 119 | is(substr($a,-5,7), '54321');# P=Q S R |
| 120 | is(substr($a,-3,0), ''); # P Q=R S |
| 121 | is(substr($a,-3,3), '321');# P Q R=S |
| 122 | is(substr($a,-2,3), '21'); # P Q S R |
| 123 | is(substr($a,0,-5), ''); # P=Q=R S |
| 124 | is(substr($a,2,-3), ''); # P Q=R S |
| 125 | is(substr($a,0,0), ''); # P=Q=R S |
| 126 | is(substr($a,0,5), '54321');# P=Q R=S |
| 127 | is(substr($a,0,7), '54321');# P=Q S R |
| 128 | is(substr($a,2,0), ''); # P Q=R S |
| 129 | is(substr($a,2,3), '321'); # P Q R=S |
| 130 | is(substr($a,5,0), ''); # P Q=R=S |
| 131 | is(substr($a,5,2), ''); # P Q=S R |
| 132 | is(substr($a,-7,-5), ''); # Q P=R S |
| 133 | is(substr($a,-7,-2), '543');# Q P R S |
| 134 | is(substr($a,-5,-5), ''); # P=Q=R S |
| 135 | is(substr($a,-5,-2), '543');# P=Q R S |
| 136 | is(substr($a,-3,-3), ''); # P Q=R S |
| 137 | is(substr($a,-3,-1), '32');# P Q R S |
| 138 | |
| 139 | $a = ''; |
| 140 | |
| 141 | is(substr($a,-2,2), ''); # Q P=R=S |
| 142 | is(substr($a,0,0), ''); # P=Q=R=S |
| 143 | is(substr($a,0,1), ''); # P=Q=S R |
| 144 | is(substr($a,-2,3), ''); # Q P=S R |
| 145 | is(substr($a,-2), ''); # Q P=R=S |
| 146 | is(substr($a,0), ''); # P=Q=R=S |
| 147 | |
| 148 | |
| 149 | is(substr($a,0,-1), ''); # R P=Q=S |
| 150 | $b = substr($a,-2, 0) ; # warn # Q=R P=S |
| 151 | is($w--, 1); |
| 152 | eval{substr($a,-2, 0) = "" ; }; # Q=R P=S |
| 153 | like($@, $FATAL_MSG); |
| 154 | |
| 155 | $b = substr($a,-2, 1) ; # warn # Q R P=S |
| 156 | is($w--, 1); |
| 157 | eval{substr($a,-2, 1) = "" ; }; # Q R P=S |
| 158 | like($@, $FATAL_MSG); |
| 159 | |
| 160 | $b = substr($a,-2,-1) ; # warn # Q R P=S |
| 161 | is($w--, 1); |
| 162 | eval{substr($a,-2,-1) = "" ; }; # Q R P=S |
| 163 | like($@, $FATAL_MSG); |
| 164 | |
| 165 | $b = substr($a,-2,-2) ; # warn # Q=R P=S |
| 166 | is($w--, 1); |
| 167 | eval{substr($a,-2,-2) = "" ; }; # Q=R P=S |
| 168 | like($@, $FATAL_MSG); |
| 169 | |
| 170 | $b = substr($a, 1,-2) ; # warn # R P=S Q |
| 171 | is($w--, 1); |
| 172 | eval{substr($a, 1,-2) = "" ; }; # R P=S Q |
| 173 | like($@, $FATAL_MSG); |
| 174 | |
| 175 | $b = substr($a, 1, 1) ; # warn # P=S Q R |
| 176 | is($w--, 1); |
| 177 | eval{substr($a, 1, 1) = "" ; }; # P=S Q R |
| 178 | like($@, $FATAL_MSG); |
| 179 | |
| 180 | $b = substr($a, 1, 0) ;# warn # P=S Q=R |
| 181 | is($w--, 1); |
| 182 | eval{substr($a, 1, 0) = "" ; }; # P=S Q=R |
| 183 | like($@, $FATAL_MSG); |
| 184 | |
| 185 | $b = substr($a,1) ; # warning # P=R=S Q |
| 186 | is($w--, 1); |
| 187 | eval{substr($a,1) = "" ; }; # P=R=S Q |
| 188 | like($@, $FATAL_MSG); |
| 189 | |
| 190 | $b = substr($a,-7,-6) ; # warn # Q R P S |
| 191 | is($w--, 1); |
| 192 | eval{substr($a,-7,-6) = "" ; }; # Q R P S |
| 193 | like($@, $FATAL_MSG); |
| 194 | |
| 195 | my $a = 'zxcvbnm'; |
| 196 | substr($a,2,0) = ''; |
| 197 | is($a, 'zxcvbnm'); |
| 198 | substr($a,7,0) = ''; |
| 199 | is($a, 'zxcvbnm'); |
| 200 | substr($a,5,0) = ''; |
| 201 | is($a, 'zxcvbnm'); |
| 202 | substr($a,0,2) = 'pq'; |
| 203 | is($a, 'pqcvbnm'); |
| 204 | substr($a,2,0) = 'r'; |
| 205 | is($a, 'pqrcvbnm'); |
| 206 | substr($a,8,0) = 'asd'; |
| 207 | is($a, 'pqrcvbnmasd'); |
| 208 | substr($a,0,2) = 'iop'; |
| 209 | is($a, 'ioprcvbnmasd'); |
| 210 | substr($a,0,5) = 'fgh'; |
| 211 | is($a, 'fghvbnmasd'); |
| 212 | substr($a,3,5) = 'jkl'; |
| 213 | is($a, 'fghjklsd'); |
| 214 | substr($a,3,2) = '1234'; |
| 215 | is($a, 'fgh1234lsd'); |
| 216 | |
| 217 | |
| 218 | # with lexicals (and in re-entered scopes) |
| 219 | for (0,1) { |
| 220 | my $txt; |
| 221 | unless ($_) { |
| 222 | $txt = "Foo"; |
| 223 | substr($txt, -1) = "X"; |
| 224 | is($txt, "FoX"); |
| 225 | } |
| 226 | else { |
| 227 | substr($txt, 0, 1) = "X"; |
| 228 | is($txt, "X"); |
| 229 | } |
| 230 | } |
| 231 | |
| 232 | $w = 0 ; |
| 233 | # coercion of references |
| 234 | { |
| 235 | my $s = []; |
| 236 | substr($s, 0, 1) = 'Foo'; |
| 237 | is (substr($s,0,7), "FooRRAY"); |
| 238 | is ($w,2); |
| 239 | $w = 0; |
| 240 | } |
| 241 | |
| 242 | # check no spurious warnings |
| 243 | is($w, 0); |
| 244 | |
| 245 | # check new 4 arg replacement syntax |
| 246 | $a = "abcxyz"; |
| 247 | $w = 0; |
| 248 | is(substr($a, 0, 3, ""), "abc"); |
| 249 | is($a, "xyz"); |
| 250 | is(substr($a, 0, 0, "abc"), ""); |
| 251 | is($a, "abcxyz"); |
| 252 | is(substr($a, 3, -1, ""), "xy"); |
| 253 | is($a, "abcz"); |
| 254 | |
| 255 | is(substr($a, 3, undef, "xy"), ""); |
| 256 | is($a, "abcxyz"); |
| 257 | is($w, 3); |
| 258 | |
| 259 | $w = 0; |
| 260 | |
| 261 | is(substr($a, 3, 9999999, ""), "xyz"); |
| 262 | is($a, "abc"); |
| 263 | eval{substr($a, -99, 0, "") }; |
| 264 | like($@, $FATAL_MSG); |
| 265 | eval{substr($a, 99, 3, "") }; |
| 266 | like($@, $FATAL_MSG); |
| 267 | |
| 268 | substr($a, 0, length($a), "foo"); |
| 269 | is ($a, "foo"); |
| 270 | is ($w, 0); |
| 271 | |
| 272 | # using 4 arg substr as lvalue is a compile time error |
| 273 | eval 'substr($a,0,0,"") = "abc"'; |
| 274 | like ($@, qr/Can't modify substr/); |
| 275 | is ($a, "foo"); |
| 276 | |
| 277 | $a = "abcdefgh"; |
| 278 | is(sub { shift }->(substr($a, 0, 4, "xxxx")), 'abcd'); |
| 279 | is($a, 'xxxxefgh'); |
| 280 | |
| 281 | { |
| 282 | my $y = 10; |
| 283 | $y = "2" . $y; |
| 284 | is ($y, 210); |
| 285 | } |
| 286 | |
| 287 | # utf8 sanity |
| 288 | { |
| 289 | my $x = substr("a\x{263a}b",0); |
| 290 | is(length($x), 3); |
| 291 | $x = substr($x,1,1); |
| 292 | is($x, "\x{263a}"); |
| 293 | $x = $x x 2; |
| 294 | is(length($x), 2); |
| 295 | substr($x,0,1) = "abcd"; |
| 296 | is($x, "abcd\x{263a}"); |
| 297 | is(length($x), 5); |
| 298 | $x = reverse $x; |
| 299 | is(length($x), 5); |
| 300 | is($x, "\x{263a}dcba"); |
| 301 | |
| 302 | my $z = 10; |
| 303 | $z = "21\x{263a}" . $z; |
| 304 | is(length($z), 5); |
| 305 | is($z, "21\x{263a}10"); |
| 306 | } |
| 307 | |
| 308 | # replacement should work on magical values |
| 309 | require Tie::Scalar; |
| 310 | my %data; |
| 311 | tie $data{'a'}, 'Tie::StdScalar'; # makes $data{'a'} magical |
| 312 | $data{a} = "firstlast"; |
| 313 | is(substr($data{'a'}, 0, 5, ""), "first"); |
| 314 | is($data{'a'}, "last"); |
| 315 | |
| 316 | # more utf8 |
| 317 | |
| 318 | # The following two originally from Ignasi Roca. |
| 319 | |
| 320 | $x = "\xF1\xF2\xF3"; |
| 321 | substr($x, 0, 1) = "\x{100}"; # Ignasi had \x{FF} |
| 322 | is(length($x), 3); |
| 323 | is($x, "\x{100}\xF2\xF3"); |
| 324 | is(substr($x, 0, 1), "\x{100}"); |
| 325 | is(substr($x, 1, 1), "\x{F2}"); |
| 326 | is(substr($x, 2, 1), "\x{F3}"); |
| 327 | |
| 328 | $x = "\xF1\xF2\xF3"; |
| 329 | substr($x, 0, 1) = "\x{100}\x{FF}"; # Ignasi had \x{FF} |
| 330 | is(length($x), 4); |
| 331 | is($x, "\x{100}\x{FF}\xF2\xF3"); |
| 332 | is(substr($x, 0, 1), "\x{100}"); |
| 333 | is(substr($x, 1, 1), "\x{FF}"); |
| 334 | is(substr($x, 2, 1), "\x{F2}"); |
| 335 | is(substr($x, 3, 1), "\x{F3}"); |
| 336 | |
| 337 | # more utf8 lval exercise |
| 338 | |
| 339 | $x = "\xF1\xF2\xF3"; |
| 340 | substr($x, 0, 2) = "\x{100}\xFF"; |
| 341 | is(length($x), 3); |
| 342 | is($x, "\x{100}\xFF\xF3"); |
| 343 | is(substr($x, 0, 1), "\x{100}"); |
| 344 | is(substr($x, 1, 1), "\x{FF}"); |
| 345 | is(substr($x, 2, 1), "\x{F3}"); |
| 346 | |
| 347 | $x = "\xF1\xF2\xF3"; |
| 348 | substr($x, 1, 1) = "\x{100}\xFF"; |
| 349 | is(length($x), 4); |
| 350 | is($x, "\xF1\x{100}\xFF\xF3"); |
| 351 | is(substr($x, 0, 1), "\x{F1}"); |
| 352 | is(substr($x, 1, 1), "\x{100}"); |
| 353 | is(substr($x, 2, 1), "\x{FF}"); |
| 354 | is(substr($x, 3, 1), "\x{F3}"); |
| 355 | |
| 356 | $x = "\xF1\xF2\xF3"; |
| 357 | substr($x, 2, 1) = "\x{100}\xFF"; |
| 358 | is(length($x), 4); |
| 359 | is($x, "\xF1\xF2\x{100}\xFF"); |
| 360 | is(substr($x, 0, 1), "\x{F1}"); |
| 361 | is(substr($x, 1, 1), "\x{F2}"); |
| 362 | is(substr($x, 2, 1), "\x{100}"); |
| 363 | is(substr($x, 3, 1), "\x{FF}"); |
| 364 | |
| 365 | $x = "\xF1\xF2\xF3"; |
| 366 | substr($x, 3, 1) = "\x{100}\xFF"; |
| 367 | is(length($x), 5); |
| 368 | is($x, "\xF1\xF2\xF3\x{100}\xFF"); |
| 369 | is(substr($x, 0, 1), "\x{F1}"); |
| 370 | is(substr($x, 1, 1), "\x{F2}"); |
| 371 | is(substr($x, 2, 1), "\x{F3}"); |
| 372 | is(substr($x, 3, 1), "\x{100}"); |
| 373 | is(substr($x, 4, 1), "\x{FF}"); |
| 374 | |
| 375 | $x = "\xF1\xF2\xF3"; |
| 376 | substr($x, -1, 1) = "\x{100}\xFF"; |
| 377 | is(length($x), 4); |
| 378 | is($x, "\xF1\xF2\x{100}\xFF"); |
| 379 | is(substr($x, 0, 1), "\x{F1}"); |
| 380 | is(substr($x, 1, 1), "\x{F2}"); |
| 381 | is(substr($x, 2, 1), "\x{100}"); |
| 382 | is(substr($x, 3, 1), "\x{FF}"); |
| 383 | |
| 384 | $x = "\xF1\xF2\xF3"; |
| 385 | substr($x, -1, 0) = "\x{100}\xFF"; |
| 386 | is(length($x), 5); |
| 387 | is($x, "\xF1\xF2\x{100}\xFF\xF3"); |
| 388 | is(substr($x, 0, 1), "\x{F1}"); |
| 389 | is(substr($x, 1, 1), "\x{F2}"); |
| 390 | is(substr($x, 2, 1), "\x{100}"); |
| 391 | is(substr($x, 3, 1), "\x{FF}"); |
| 392 | is(substr($x, 4, 1), "\x{F3}"); |
| 393 | |
| 394 | $x = "\xF1\xF2\xF3"; |
| 395 | substr($x, 0, -1) = "\x{100}\xFF"; |
| 396 | is(length($x), 3); |
| 397 | is($x, "\x{100}\xFF\xF3"); |
| 398 | is(substr($x, 0, 1), "\x{100}"); |
| 399 | is(substr($x, 1, 1), "\x{FF}"); |
| 400 | is(substr($x, 2, 1), "\x{F3}"); |
| 401 | |
| 402 | $x = "\xF1\xF2\xF3"; |
| 403 | substr($x, 0, -2) = "\x{100}\xFF"; |
| 404 | is(length($x), 4); |
| 405 | is($x, "\x{100}\xFF\xF2\xF3"); |
| 406 | is(substr($x, 0, 1), "\x{100}"); |
| 407 | is(substr($x, 1, 1), "\x{FF}"); |
| 408 | is(substr($x, 2, 1), "\x{F2}"); |
| 409 | is(substr($x, 3, 1), "\x{F3}"); |
| 410 | |
| 411 | $x = "\xF1\xF2\xF3"; |
| 412 | substr($x, 0, -3) = "\x{100}\xFF"; |
| 413 | is(length($x), 5); |
| 414 | is($x, "\x{100}\xFF\xF1\xF2\xF3"); |
| 415 | is(substr($x, 0, 1), "\x{100}"); |
| 416 | is(substr($x, 1, 1), "\x{FF}"); |
| 417 | is(substr($x, 2, 1), "\x{F1}"); |
| 418 | is(substr($x, 3, 1), "\x{F2}"); |
| 419 | is(substr($x, 4, 1), "\x{F3}"); |
| 420 | |
| 421 | $x = "\xF1\xF2\xF3"; |
| 422 | substr($x, 1, -1) = "\x{100}\xFF"; |
| 423 | is(length($x), 4); |
| 424 | is($x, "\xF1\x{100}\xFF\xF3"); |
| 425 | is(substr($x, 0, 1), "\x{F1}"); |
| 426 | is(substr($x, 1, 1), "\x{100}"); |
| 427 | is(substr($x, 2, 1), "\x{FF}"); |
| 428 | is(substr($x, 3, 1), "\x{F3}"); |
| 429 | |
| 430 | $x = "\xF1\xF2\xF3"; |
| 431 | substr($x, -1, -1) = "\x{100}\xFF"; |
| 432 | is(length($x), 5); |
| 433 | is($x, "\xF1\xF2\x{100}\xFF\xF3"); |
| 434 | is(substr($x, 0, 1), "\x{F1}"); |
| 435 | is(substr($x, 1, 1), "\x{F2}"); |
| 436 | is(substr($x, 2, 1), "\x{100}"); |
| 437 | is(substr($x, 3, 1), "\x{FF}"); |
| 438 | is(substr($x, 4, 1), "\x{F3}"); |
| 439 | |
| 440 | # And tests for already-UTF8 one |
| 441 | |
| 442 | $x = "\x{101}\x{F2}\x{F3}"; |
| 443 | substr($x, 0, 1) = "\x{100}"; |
| 444 | is(length($x), 3); |
| 445 | is($x, "\x{100}\xF2\xF3"); |
| 446 | is(substr($x, 0, 1), "\x{100}"); |
| 447 | is(substr($x, 1, 1), "\x{F2}"); |
| 448 | is(substr($x, 2, 1), "\x{F3}"); |
| 449 | |
| 450 | $x = "\x{101}\x{F2}\x{F3}"; |
| 451 | substr($x, 0, 1) = "\x{100}\x{FF}"; |
| 452 | is(length($x), 4); |
| 453 | is($x, "\x{100}\x{FF}\xF2\xF3"); |
| 454 | is(substr($x, 0, 1), "\x{100}"); |
| 455 | is(substr($x, 1, 1), "\x{FF}"); |
| 456 | is(substr($x, 2, 1), "\x{F2}"); |
| 457 | is(substr($x, 3, 1), "\x{F3}"); |
| 458 | |
| 459 | $x = "\x{101}\x{F2}\x{F3}"; |
| 460 | substr($x, 0, 2) = "\x{100}\xFF"; |
| 461 | is(length($x), 3); |
| 462 | is($x, "\x{100}\xFF\xF3"); |
| 463 | is(substr($x, 0, 1), "\x{100}"); |
| 464 | is(substr($x, 1, 1), "\x{FF}"); |
| 465 | is(substr($x, 2, 1), "\x{F3}"); |
| 466 | |
| 467 | $x = "\x{101}\x{F2}\x{F3}"; |
| 468 | substr($x, 1, 1) = "\x{100}\xFF"; |
| 469 | is(length($x), 4); |
| 470 | is($x, "\x{101}\x{100}\xFF\xF3"); |
| 471 | is(substr($x, 0, 1), "\x{101}"); |
| 472 | is(substr($x, 1, 1), "\x{100}"); |
| 473 | is(substr($x, 2, 1), "\x{FF}"); |
| 474 | is(substr($x, 3, 1), "\x{F3}"); |
| 475 | |
| 476 | $x = "\x{101}\x{F2}\x{F3}"; |
| 477 | substr($x, 2, 1) = "\x{100}\xFF"; |
| 478 | is(length($x), 4); |
| 479 | is($x, "\x{101}\xF2\x{100}\xFF"); |
| 480 | is(substr($x, 0, 1), "\x{101}"); |
| 481 | is(substr($x, 1, 1), "\x{F2}"); |
| 482 | is(substr($x, 2, 1), "\x{100}"); |
| 483 | is(substr($x, 3, 1), "\x{FF}"); |
| 484 | |
| 485 | $x = "\x{101}\x{F2}\x{F3}"; |
| 486 | substr($x, 3, 1) = "\x{100}\xFF"; |
| 487 | is(length($x), 5); |
| 488 | is($x, "\x{101}\x{F2}\x{F3}\x{100}\xFF"); |
| 489 | is(substr($x, 0, 1), "\x{101}"); |
| 490 | is(substr($x, 1, 1), "\x{F2}"); |
| 491 | is(substr($x, 2, 1), "\x{F3}"); |
| 492 | is(substr($x, 3, 1), "\x{100}"); |
| 493 | is(substr($x, 4, 1), "\x{FF}"); |
| 494 | |
| 495 | $x = "\x{101}\x{F2}\x{F3}"; |
| 496 | substr($x, -1, 1) = "\x{100}\xFF"; |
| 497 | is(length($x), 4); |
| 498 | is($x, "\x{101}\xF2\x{100}\xFF"); |
| 499 | is(substr($x, 0, 1), "\x{101}"); |
| 500 | is(substr($x, 1, 1), "\x{F2}"); |
| 501 | is(substr($x, 2, 1), "\x{100}"); |
| 502 | is(substr($x, 3, 1), "\x{FF}"); |
| 503 | |
| 504 | $x = "\x{101}\x{F2}\x{F3}"; |
| 505 | substr($x, -1, 0) = "\x{100}\xFF"; |
| 506 | is(length($x), 5); |
| 507 | is($x, "\x{101}\xF2\x{100}\xFF\xF3"); |
| 508 | is(substr($x, 0, 1), "\x{101}"); |
| 509 | is(substr($x, 1, 1), "\x{F2}"); |
| 510 | is(substr($x, 2, 1), "\x{100}"); |
| 511 | is(substr($x, 3, 1), "\x{FF}"); |
| 512 | is(substr($x, 4, 1), "\x{F3}"); |
| 513 | |
| 514 | $x = "\x{101}\x{F2}\x{F3}"; |
| 515 | substr($x, 0, -1) = "\x{100}\xFF"; |
| 516 | is(length($x), 3); |
| 517 | is($x, "\x{100}\xFF\xF3"); |
| 518 | is(substr($x, 0, 1), "\x{100}"); |
| 519 | is(substr($x, 1, 1), "\x{FF}"); |
| 520 | is(substr($x, 2, 1), "\x{F3}"); |
| 521 | |
| 522 | $x = "\x{101}\x{F2}\x{F3}"; |
| 523 | substr($x, 0, -2) = "\x{100}\xFF"; |
| 524 | is(length($x), 4); |
| 525 | is($x, "\x{100}\xFF\xF2\xF3"); |
| 526 | is(substr($x, 0, 1), "\x{100}"); |
| 527 | is(substr($x, 1, 1), "\x{FF}"); |
| 528 | is(substr($x, 2, 1), "\x{F2}"); |
| 529 | is(substr($x, 3, 1), "\x{F3}"); |
| 530 | |
| 531 | $x = "\x{101}\x{F2}\x{F3}"; |
| 532 | substr($x, 0, -3) = "\x{100}\xFF"; |
| 533 | is(length($x), 5); |
| 534 | is($x, "\x{100}\xFF\x{101}\x{F2}\x{F3}"); |
| 535 | is(substr($x, 0, 1), "\x{100}"); |
| 536 | is(substr($x, 1, 1), "\x{FF}"); |
| 537 | is(substr($x, 2, 1), "\x{101}"); |
| 538 | is(substr($x, 3, 1), "\x{F2}"); |
| 539 | is(substr($x, 4, 1), "\x{F3}"); |
| 540 | |
| 541 | $x = "\x{101}\x{F2}\x{F3}"; |
| 542 | substr($x, 1, -1) = "\x{100}\xFF"; |
| 543 | is(length($x), 4); |
| 544 | is($x, "\x{101}\x{100}\xFF\xF3"); |
| 545 | is(substr($x, 0, 1), "\x{101}"); |
| 546 | is(substr($x, 1, 1), "\x{100}"); |
| 547 | is(substr($x, 2, 1), "\x{FF}"); |
| 548 | is(substr($x, 3, 1), "\x{F3}"); |
| 549 | |
| 550 | $x = "\x{101}\x{F2}\x{F3}"; |
| 551 | substr($x, -1, -1) = "\x{100}\xFF"; |
| 552 | is(length($x), 5); |
| 553 | is($x, "\x{101}\xF2\x{100}\xFF\xF3"); |
| 554 | is(substr($x, 0, 1), "\x{101}"); |
| 555 | is(substr($x, 1, 1), "\x{F2}"); |
| 556 | is(substr($x, 2, 1), "\x{100}"); |
| 557 | is(substr($x, 3, 1), "\x{FF}"); |
| 558 | is(substr($x, 4, 1), "\x{F3}"); |
| 559 | |
| 560 | substr($x = "ab", 0, 0, "\x{100}\x{200}"); |
| 561 | is($x, "\x{100}\x{200}ab"); |
| 562 | |
| 563 | substr($x = "\x{100}\x{200}", 0, 0, "ab"); |
| 564 | is($x, "ab\x{100}\x{200}"); |
| 565 | |
| 566 | substr($x = "ab", 1, 0, "\x{100}\x{200}"); |
| 567 | is($x, "a\x{100}\x{200}b"); |
| 568 | |
| 569 | substr($x = "\x{100}\x{200}", 1, 0, "ab"); |
| 570 | is($x, "\x{100}ab\x{200}"); |
| 571 | |
| 572 | substr($x = "ab", 2, 0, "\x{100}\x{200}"); |
| 573 | is($x, "ab\x{100}\x{200}"); |
| 574 | |
| 575 | substr($x = "\x{100}\x{200}", 2, 0, "ab"); |
| 576 | is($x, "\x{100}\x{200}ab"); |
| 577 | |
| 578 | substr($x = "\xFFb", 0, 0, "\x{100}\x{200}"); |
| 579 | is($x, "\x{100}\x{200}\xFFb"); |
| 580 | |
| 581 | substr($x = "\x{100}\x{200}", 0, 0, "\xFFb"); |
| 582 | is($x, "\xFFb\x{100}\x{200}"); |
| 583 | |
| 584 | substr($x = "\xFFb", 1, 0, "\x{100}\x{200}"); |
| 585 | is($x, "\xFF\x{100}\x{200}b"); |
| 586 | |
| 587 | substr($x = "\x{100}\x{200}", 1, 0, "\xFFb"); |
| 588 | is($x, "\x{100}\xFFb\x{200}"); |
| 589 | |
| 590 | substr($x = "\xFFb", 2, 0, "\x{100}\x{200}"); |
| 591 | is($x, "\xFFb\x{100}\x{200}"); |
| 592 | |
| 593 | substr($x = "\x{100}\x{200}", 2, 0, "\xFFb"); |
| 594 | is($x, "\x{100}\x{200}\xFFb"); |
| 595 | |
| 596 | # [perl #20933] |
| 597 | { |
| 598 | my $s = "ab"; |
| 599 | my @r; |
| 600 | $r[$_] = \ substr $s, $_, 1 for (0, 1); |
| 601 | is(join("", map { $$_ } @r), "ab"); |
| 602 | } |
| 603 | |
| 604 | # [perl #23207] |
| 605 | { |
| 606 | sub ss { |
| 607 | substr($_[0],0,1) ^= substr($_[0],1,1) ^= |
| 608 | substr($_[0],0,1) ^= substr($_[0],1,1); |
| 609 | } |
| 610 | my $x = my $y = 'AB'; ss $x; ss $y; |
| 611 | is($x, $y); |
| 612 | } |
| 613 | |
| 614 | # [perl #24605] |
| 615 | { |
| 616 | my $x = "0123456789\x{500}"; |
| 617 | my $y = substr $x, 4; |
| 618 | is(substr($x, 7, 1), "7"); |
| 619 | } |
| 620 | |
| 621 | # multiple assignments to lvalue [perl #24346] |
| 622 | { |
| 623 | my $x = "abcdef"; |
| 624 | for (substr($x,1,3)) { |
| 625 | is($_, 'bcd'); |
| 626 | $_ = 'XX'; |
| 627 | is($_, 'XX'); |
| 628 | is($x, 'aXXef'); |
| 629 | $_ = "\xFF"; |
| 630 | is($_, "\xFF"); |
| 631 | is($x, "a\xFFef"); |
| 632 | $_ = "\xF1\xF2\xF3\xF4\xF5\xF6"; |
| 633 | is($_, "\xF1\xF2\xF3\xF4\xF5\xF6"); |
| 634 | is($x, "a\xF1\xF2\xF3\xF4\xF5\xF6ef"); |
| 635 | $_ = 'YYYY'; |
| 636 | is($_, 'YYYY'); |
| 637 | is($x, 'aYYYYef'); |
| 638 | } |
| 639 | $x = "abcdef"; |
| 640 | for (substr($x,1)) { |
| 641 | is($_, 'bcdef'); |
| 642 | $_ = 'XX'; |
| 643 | is($_, 'XX'); |
| 644 | is($x, 'aXX'); |
| 645 | $x .= "frompswiggle"; |
| 646 | is $_, "XXfrompswiggle"; |
| 647 | } |
| 648 | $x = "abcdef"; |
| 649 | for (substr($x,1,-1)) { |
| 650 | is($_, 'bcde'); |
| 651 | $_ = 'XX'; |
| 652 | is($_, 'XX'); |
| 653 | is($x, 'aXXf'); |
| 654 | $x .= "frompswiggle"; |
| 655 | is $_, "XXffrompswiggl"; |
| 656 | } |
| 657 | $x = "abcdef"; |
| 658 | for (substr($x,-5,3)) { |
| 659 | is($_, 'bcd'); |
| 660 | $_ = 'XX'; # now $_ is substr($x, -4, 2) |
| 661 | is($_, 'XX'); |
| 662 | is($x, 'aXXef'); |
| 663 | $x .= "frompswiggle"; |
| 664 | is $_, "gg"; |
| 665 | } |
| 666 | $x = "abcdef"; |
| 667 | for (substr($x,-5)) { |
| 668 | is($_, 'bcdef'); |
| 669 | $_ = 'XX'; # now substr($x, -2) |
| 670 | is($_, 'XX'); |
| 671 | is($x, 'aXX'); |
| 672 | $x .= "frompswiggle"; |
| 673 | is $_, "le"; |
| 674 | } |
| 675 | $x = "abcdef"; |
| 676 | for (substr($x,-5,-1)) { |
| 677 | is($_, 'bcde'); |
| 678 | $_ = 'XX'; # now substr($x, -3, -1) |
| 679 | is($_, 'XX'); |
| 680 | is($x, 'aXXf'); |
| 681 | $x .= "frompswiggle"; |
| 682 | is $_, "gl"; |
| 683 | } |
| 684 | } |
| 685 | |
| 686 | # Also part of perl #24346; scalar(substr...) should not affect lvalueness |
| 687 | { |
| 688 | my $str = "abcdef"; |
| 689 | sub { $_[0] = 'dea' }->( scalar substr $str, 3, 2 ); |
| 690 | is $str, 'abcdeaf', 'scalar does not affect lvalueness of substr'; |
| 691 | } |
| 692 | |
| 693 | # [perl #24200] string corruption with lvalue sub |
| 694 | |
| 695 | { |
| 696 | sub bar: lvalue { substr $krunch, 0 } |
| 697 | bar = "XXX"; |
| 698 | is(bar, 'XXX'); |
| 699 | $krunch = '123456789'; |
| 700 | is(bar, '123456789'); |
| 701 | } |
| 702 | |
| 703 | # [perl #29149] |
| 704 | { |
| 705 | my $text = "0123456789\xED "; |
| 706 | utf8::upgrade($text); |
| 707 | my $pos = 5; |
| 708 | pos($text) = $pos; |
| 709 | my $a = substr($text, $pos, $pos); |
| 710 | is(substr($text,$pos,1), $pos); |
| 711 | |
| 712 | } |
| 713 | |
| 714 | # [perl #34976] incorrect caching of utf8 substr length |
| 715 | { |
| 716 | my $a = "abcd\x{100}"; |
| 717 | is(substr($a,1,2), 'bc'); |
| 718 | is(substr($a,1,1), 'b'); |
| 719 | } |
| 720 | |
| 721 | # [perl #62646] offsets exceeding 32 bits on 64-bit system |
| 722 | SKIP: { |
| 723 | skip("32-bit system", 24) unless ~0 > 0xffffffff; |
| 724 | my $a = "abc"; |
| 725 | my $s; |
| 726 | my $r; |
| 727 | |
| 728 | utf8::downgrade($a); |
| 729 | for (1..2) { |
| 730 | $w = 0; |
| 731 | $r = substr($a, 0xffffffff, 1); |
| 732 | is($r, undef); |
| 733 | is($w, 1); |
| 734 | |
| 735 | $w = 0; |
| 736 | $r = substr($a, 0xffffffff+1, 1); |
| 737 | is($r, undef); |
| 738 | is($w, 1); |
| 739 | |
| 740 | $w = 0; |
| 741 | ok( !eval { $r = substr($s=$a, 0xffffffff, 1, "_"); 1 } ); |
| 742 | is($r, undef); |
| 743 | is($s, $a); |
| 744 | is($w, 0); |
| 745 | |
| 746 | $w = 0; |
| 747 | ok( !eval { $r = substr($s=$a, 0xffffffff+1, 1, "_"); 1 } ); |
| 748 | is($r, undef); |
| 749 | is($s, $a); |
| 750 | is($w, 0); |
| 751 | |
| 752 | utf8::upgrade($a); |
| 753 | } |
| 754 | } |
| 755 | |
| 756 | # [perl #77692] UTF8 cache not being reset when TARG is reused |
| 757 | ok eval { |
| 758 | local ${^UTF8CACHE} = -1; |
| 759 | for my $i (0..1) |
| 760 | { |
| 761 | my $dummy = length(substr("\x{100}",0,$i)); |
| 762 | } |
| 763 | 1 |
| 764 | }, 'UTF8 cache is reset when TARG is reused [perl #77692]'; |
| 765 | |
| 766 | { |
| 767 | use utf8; |
| 768 | use open qw( :utf8 :std ); |
| 769 | no warnings 'once'; |
| 770 | |
| 771 | my $t = ""; |
| 772 | substr $t, 0, 0, *ワルド; |
| 773 | is($t, "*main::ワルド", "substr works on UTF-8 globs"); |
| 774 | |
| 775 | $t = "The World!"; |
| 776 | substr $t, 0, 9, *ザ::ワルド; |
| 777 | is($t, "*ザ::ワルド!", "substr works on a UTF-8 glob + stash"); |
| 778 | } |
| 779 | |
| 780 | { |
| 781 | my $x = *foo; |
| 782 | my $y = \substr *foo, 0, 0; |
| 783 | is ref \$x, 'GLOB', '\substr does not coerce its glob arg just yet'; |
| 784 | $x = \"foo"; |
| 785 | $y = \substr *foo, 0, 0; |
| 786 | is ref \$x, 'REF', '\substr does not coerce its ref arg just yet'; |
| 787 | } |
| 788 | |
| 789 | # Test that UTF8-ness of magic var changing does not confuse substr lvalue |
| 790 | # assignment. |
| 791 | # We use overloading for our magic var, but a typeglob would work, too. |
| 792 | package o { |
| 793 | use overload '""' => sub { ++our $count; $_[0][0] } |
| 794 | } |
| 795 | my $refee = bless ["\x{100}a"], o::; |
| 796 | my $substr = \substr $refee, -2; # UTF8 flag still off for $$substr. |
| 797 | $$substr = "b"; # UTF8 flag turns on when setsubstr |
| 798 | is $refee, "b", # magic stringifies $$substr. |
| 799 | 'substr lvalue assignment when stringification turns on UTF8ness'; |
| 800 | |
| 801 | # Test that changing UTF8-ness does not confuse 4-arg substr. |
| 802 | $refee = bless [], "\x{100}a"; |
| 803 | # stringify without returning on UTF8 flag on $refee: |
| 804 | my $string = $refee; $string = "$string"; |
| 805 | substr $refee, 0, 0, "\xff"; |
| 806 | is $refee, "\xff$string", |
| 807 | '4-arg substr with target UTF8ness turning on when stringified'; |
| 808 | $refee = bless [], "\x{100}"; |
| 809 | () = "$refee"; # UTF8 flag now on |
| 810 | bless $refee, "\xff"; |
| 811 | $string = $refee; $string = "$string"; |
| 812 | substr $refee, 0, 0, "\xff"; |
| 813 | is $refee, "\xff$string", |
| 814 | '4-arg substr with target UTF8ness turning off when stringified'; |
| 815 | |
| 816 | # Overload count |
| 817 | $refee = bless ["foo"], o::; |
| 818 | $o::count = 0; |
| 819 | substr $refee, 0, 0, ""; |
| 820 | is $o::count, 1, '4-arg substr calls overloading once on the target'; |
| 821 | $refee = bless ["\x{100}"], o::; |
| 822 | () = "$refee"; # turn UTF8 flag on |
| 823 | $o::count = 0; |
| 824 | () = substr $refee, 0; |
| 825 | is $o::count, 1, 'rvalue substr calls overloading once on utf8 target'; |
| 826 | $o::count = 0; |
| 827 | $refee = ""; |
| 828 | ${\substr $refee, 0} = bless ["\x{100}"], o::; |
| 829 | is $o::count, 1, 'assigning utf8 overload to substr lvalue calls ovld 1ce'; |
| 830 | |
| 831 | # [perl #7678] core dump with substr reference and localisation |
| 832 | {$b="abcde"; local $k; *k=\substr($b, 2, 1);} |
| 833 | |
| 834 | # [perl #128260] assertion failure with \substr %h, \substr @h |
| 835 | { |
| 836 | my %h = 1..100; |
| 837 | my @a = 1..100; |
| 838 | is ${\substr %h, 0}, scalar %h, '\substr %h'; |
| 839 | is ${\substr @a, 0}, scalar @a, '\substr @a'; |
| 840 | } |
| 841 | |
| 842 | } # sub run_tests - put tests above this line that can run in threads |
| 843 | |
| 844 | |
| 845 | my $destroyed; |
| 846 | { package Class; DESTROY { ++$destroyed; } } |
| 847 | |
| 848 | $destroyed = 0; |
| 849 | { |
| 850 | my $x = ''; |
| 851 | substr($x,0,1) = ""; |
| 852 | $x = bless({}, 'Class'); |
| 853 | } |
| 854 | is($destroyed, 1, 'Timely scalar destruction with lvalue substr'); |
| 855 | |
| 856 | { |
| 857 | my $result_3363; |
| 858 | sub a_3363 { |
| 859 | my ($word, $replace) = @_; |
| 860 | my $ref = \substr($word, 0, 1); |
| 861 | $$ref = $replace; |
| 862 | if ($replace eq "b") { |
| 863 | $result_3363 = $word; |
| 864 | } else { |
| 865 | a_3363($word, "b"); |
| 866 | } |
| 867 | } |
| 868 | a_3363($_, "v") for "test"; |
| 869 | |
| 870 | is($result_3363, "best", "ref-to-substr retains lvalue-ness under recursion [perl #3363]"); |
| 871 | } |
| 872 | |
| 873 | # failed with ASAN |
| 874 | fresh_perl_is('$0 = "/usr/bin/perl"; substr($0, 0, 0, $0)', '', {}, "(perl #129340) substr() with source in target"); |
| 875 | |
| 876 | |
| 877 | # [perl #130624] - heap-use-after-free, observable under asan |
| 878 | { |
| 879 | my $x = "\xE9zzzz"; |
| 880 | my $y = "\x{100}"; |
| 881 | my $z = substr $x, 0, 1, $y; |
| 882 | is $z, "\xE9", "RT#130624: heap-use-after-free in 4-arg substr (ret)"; |
| 883 | is $x, "\x{100}zzzz", "RT#130624: heap-use-after-free in 4-arg substr (targ)"; |
| 884 | } |
| 885 | |
| 886 | { |
| 887 | our @ta; |
| 888 | $#ta = -1; |
| 889 | substr($#ta, 0, 2) = 23; |
| 890 | is $#ta, 23; |
| 891 | $#ta = -1; |
| 892 | substr($#ta, 0, 2) =~ s/\A..\z/23/s; |
| 893 | is $#ta, 23; |
| 894 | $#ta = -1; |
| 895 | substr($#ta, 0, 2, 23); |
| 896 | is $#ta, 23; |
| 897 | sub ta_tindex :lvalue { $#ta } |
| 898 | $#ta = -1; |
| 899 | ta_tindex() = 23; |
| 900 | is $#ta, 23; |
| 901 | $#ta = -1; |
| 902 | substr(ta_tindex(), 0, 2) = 23; |
| 903 | is $#ta, 23; |
| 904 | $#ta = -1; |
| 905 | substr(ta_tindex(), 0, 2) =~ s/\A..\z/23/s; |
| 906 | is $#ta, 23; |
| 907 | $#ta = -1; |
| 908 | substr(ta_tindex(), 0, 2, 23); |
| 909 | is $#ta, 23; |
| 910 | } |
| 911 | |
| 912 | { # [perl #132527] |
| 913 | use feature 'refaliasing'; |
| 914 | no warnings 'experimental::refaliasing'; |
| 915 | my %h; |
| 916 | \$h{foo} = \(my $bar = "baz"); |
| 917 | substr delete $h{foo}, 1, 1, o=>; |
| 918 | is $bar, boz => 'first arg to 4-arg substr is loose lvalue context'; |
| 919 | } |
| 920 | |
| 921 | 1; |