1#!./perl 2 3#P = start of string Q = start of substr R = end of substr S = end of string 4 5BEGIN { 6 chdir 't' if -d 't'; 7 require './test.pl'; 8 set_up_inc('../lib'); 9} 10use 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 25plan(400); 26 27run_tests() unless caller; 28 29my $krunch = "a"; 30 31sub run_tests { 32 33$FATAL_MSG = qr/^substr outside of string/; 34 35is(substr($a,0,3), 'abc'); # P=Q R S 36is(substr($a,3,3), 'def'); # P Q R S 37is(substr($a,6,999), 'xyz'); # P Q S R 38$b = substr($a,999,999) ; # warn # P R Q S 39is ($w--, 1); 40eval{substr($a,999,999) = "" ; };# P R Q S 41like ($@, $FATAL_MSG); 42is(substr($a,0,-6), 'abc'); # P=Q R S 43is(substr($a,-3,1), 'x'); # P Q R S 44sub{$b = shift}->(substr($a,999,999)); 45is ($w--, 1, 'boundless lvalue substr only warns on fetch'); 46 47substr($a,3,3) = 'XYZ'; 48is($a, 'abcXYZxyz' ); 49substr($a,0,2) = ''; 50is($a, 'cXYZxyz' ); 51substr($a,0,0) = 'ab'; 52is($a, 'abcXYZxyz' ); 53substr($a,0,0) = '12345678'; 54is($a, '12345678abcXYZxyz' ); 55substr($a,-3,3) = 'def'; 56is($a, '12345678abcXYZdef'); 57substr($a,-3,3) = '<'; 58is($a, '12345678abcXYZ<' ); 59substr($a,-1,1) = '12345678'; 60is($a, '12345678abcXYZ12345678' ); 61 62$a = 'abcdefxyz'; 63 64is(substr($a,6), 'xyz' ); # P Q R=S 65is(substr($a,-3), 'xyz' ); # P Q R=S 66$b = substr($a,999,999) ; # warning # P R=S Q 67is($w--, 1); 68eval{substr($a,999,999) = "" ; } ; # P R=S Q 69like($@, $FATAL_MSG); 70is(substr($a,0), 'abcdefxyz'); # P=Q R=S 71is(substr($a,9), ''); # P Q=R=S 72is(substr($a,-11), 'abcdefxyz'); # Q P R=S 73is(substr($a,-9), 'abcdefxyz'); # P=Q R=S 74 75$a = '54321'; 76 77$b = substr($a,-7, 1) ; # warn # Q R P S 78is($w--, 1); 79eval{substr($a,-7, 1) = "" ; }; # Q R P S 80like($@, $FATAL_MSG); 81$b = substr($a,-7,-6) ; # warn # Q R P S 82is($w--, 1); 83eval{substr($a,-7,-6) = "" ; }; # Q R P S 84like($@, $FATAL_MSG); 85is(substr($a,-5,-7), ''); # R P=Q S 86is(substr($a, 2,-7), ''); # R P Q S 87is(substr($a,-3,-7), ''); # R P Q S 88is(substr($a, 2,-5), ''); # P=R Q S 89is(substr($a,-3,-5), ''); # P=R Q S 90is(substr($a, 2,-4), ''); # P R Q S 91is(substr($a,-3,-4), ''); # P R Q S 92is(substr($a, 5,-6), ''); # R P Q=S 93is(substr($a, 5,-5), ''); # P=R Q S 94is(substr($a, 5,-3), ''); # P R Q=S 95$b = substr($a, 7,-7) ; # warn # R P S Q 96is($w--, 1); 97eval{substr($a, 7,-7) = "" ; }; # R P S Q 98like($@, $FATAL_MSG); 99$b = substr($a, 7,-5) ; # warn # P=R S Q 100is($w--, 1); 101eval{substr($a, 7,-5) = "" ; }; # P=R S Q 102like($@, $FATAL_MSG); 103$b = substr($a, 7,-3) ; # warn # P Q S Q 104is($w--, 1); 105eval{substr($a, 7,-3) = "" ; }; # P Q S Q 106like($@, $FATAL_MSG); 107$b = substr($a, 7, 0) ; # warn # P S Q=R 108is($w--, 1); 109eval{substr($a, 7, 0) = "" ; }; # P S Q=R 110like($@, $FATAL_MSG); 111 112is(substr($a,-7,2), ''); # Q P=R S 113is(substr($a,-7,4), '54'); # Q P R S 114is(substr($a,-7,7), '54321');# Q P R=S 115is(substr($a,-7,9), '54321');# Q P S R 116is(substr($a,-5,0), ''); # P=Q=R S 117is(substr($a,-5,3), '543');# P=Q R S 118is(substr($a,-5,5), '54321');# P=Q R=S 119is(substr($a,-5,7), '54321');# P=Q S R 120is(substr($a,-3,0), ''); # P Q=R S 121is(substr($a,-3,3), '321');# P Q R=S 122is(substr($a,-2,3), '21'); # P Q S R 123is(substr($a,0,-5), ''); # P=Q=R S 124is(substr($a,2,-3), ''); # P Q=R S 125is(substr($a,0,0), ''); # P=Q=R S 126is(substr($a,0,5), '54321');# P=Q R=S 127is(substr($a,0,7), '54321');# P=Q S R 128is(substr($a,2,0), ''); # P Q=R S 129is(substr($a,2,3), '321'); # P Q R=S 130is(substr($a,5,0), ''); # P Q=R=S 131is(substr($a,5,2), ''); # P Q=S R 132is(substr($a,-7,-5), ''); # Q P=R S 133is(substr($a,-7,-2), '543');# Q P R S 134is(substr($a,-5,-5), ''); # P=Q=R S 135is(substr($a,-5,-2), '543');# P=Q R S 136is(substr($a,-3,-3), ''); # P Q=R S 137is(substr($a,-3,-1), '32');# P Q R S 138 139$a = ''; 140 141is(substr($a,-2,2), ''); # Q P=R=S 142is(substr($a,0,0), ''); # P=Q=R=S 143is(substr($a,0,1), ''); # P=Q=S R 144is(substr($a,-2,3), ''); # Q P=S R 145is(substr($a,-2), ''); # Q P=R=S 146is(substr($a,0), ''); # P=Q=R=S 147 148 149is(substr($a,0,-1), ''); # R P=Q=S 150$b = substr($a,-2, 0) ; # warn # Q=R P=S 151is($w--, 1); 152eval{substr($a,-2, 0) = "" ; }; # Q=R P=S 153like($@, $FATAL_MSG); 154 155$b = substr($a,-2, 1) ; # warn # Q R P=S 156is($w--, 1); 157eval{substr($a,-2, 1) = "" ; }; # Q R P=S 158like($@, $FATAL_MSG); 159 160$b = substr($a,-2,-1) ; # warn # Q R P=S 161is($w--, 1); 162eval{substr($a,-2,-1) = "" ; }; # Q R P=S 163like($@, $FATAL_MSG); 164 165$b = substr($a,-2,-2) ; # warn # Q=R P=S 166is($w--, 1); 167eval{substr($a,-2,-2) = "" ; }; # Q=R P=S 168like($@, $FATAL_MSG); 169 170$b = substr($a, 1,-2) ; # warn # R P=S Q 171is($w--, 1); 172eval{substr($a, 1,-2) = "" ; }; # R P=S Q 173like($@, $FATAL_MSG); 174 175$b = substr($a, 1, 1) ; # warn # P=S Q R 176is($w--, 1); 177eval{substr($a, 1, 1) = "" ; }; # P=S Q R 178like($@, $FATAL_MSG); 179 180$b = substr($a, 1, 0) ;# warn # P=S Q=R 181is($w--, 1); 182eval{substr($a, 1, 0) = "" ; }; # P=S Q=R 183like($@, $FATAL_MSG); 184 185$b = substr($a,1) ; # warning # P=R=S Q 186is($w--, 1); 187eval{substr($a,1) = "" ; }; # P=R=S Q 188like($@, $FATAL_MSG); 189 190$b = substr($a,-7,-6) ; # warn # Q R P S 191is($w--, 1); 192eval{substr($a,-7,-6) = "" ; }; # Q R P S 193like($@, $FATAL_MSG); 194 195my $a = 'zxcvbnm'; 196substr($a,2,0) = ''; 197is($a, 'zxcvbnm'); 198substr($a,7,0) = ''; 199is($a, 'zxcvbnm'); 200substr($a,5,0) = ''; 201is($a, 'zxcvbnm'); 202substr($a,0,2) = 'pq'; 203is($a, 'pqcvbnm'); 204substr($a,2,0) = 'r'; 205is($a, 'pqrcvbnm'); 206substr($a,8,0) = 'asd'; 207is($a, 'pqrcvbnmasd'); 208substr($a,0,2) = 'iop'; 209is($a, 'ioprcvbnmasd'); 210substr($a,0,5) = 'fgh'; 211is($a, 'fghvbnmasd'); 212substr($a,3,5) = 'jkl'; 213is($a, 'fghjklsd'); 214substr($a,3,2) = '1234'; 215is($a, 'fgh1234lsd'); 216 217 218# with lexicals (and in re-entered scopes) 219for (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 243is($w, 0); 244 245# check new 4 arg replacement syntax 246$a = "abcxyz"; 247$w = 0; 248is(substr($a, 0, 3, ""), "abc"); 249is($a, "xyz"); 250is(substr($a, 0, 0, "abc"), ""); 251is($a, "abcxyz"); 252is(substr($a, 3, -1, ""), "xy"); 253is($a, "abcz"); 254 255is(substr($a, 3, undef, "xy"), ""); 256is($a, "abcxyz"); 257is($w, 3); 258 259$w = 0; 260 261is(substr($a, 3, 9999999, ""), "xyz"); 262is($a, "abc"); 263eval{substr($a, -99, 0, "") }; 264like($@, $FATAL_MSG); 265eval{substr($a, 99, 3, "") }; 266like($@, $FATAL_MSG); 267 268substr($a, 0, length($a), "foo"); 269is ($a, "foo"); 270is ($w, 0); 271 272# using 4 arg substr as lvalue is a compile time error 273eval 'substr($a,0,0,"") = "abc"'; 274like ($@, qr/Can't modify substr/); 275is ($a, "foo"); 276 277$a = "abcdefgh"; 278is(sub { shift }->(substr($a, 0, 4, "xxxx")), 'abcd'); 279is($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 309require Tie::Scalar; 310my %data; 311tie $data{'a'}, 'Tie::StdScalar'; # makes $data{'a'} magical 312$data{a} = "firstlast"; 313is(substr($data{'a'}, 0, 5, ""), "first"); 314is($data{'a'}, "last"); 315 316# more utf8 317 318# The following two originally from Ignasi Roca. 319 320$x = "\xF1\xF2\xF3"; 321substr($x, 0, 1) = "\x{100}"; # Ignasi had \x{FF} 322is(length($x), 3); 323is($x, "\x{100}\xF2\xF3"); 324is(substr($x, 0, 1), "\x{100}"); 325is(substr($x, 1, 1), "\x{F2}"); 326is(substr($x, 2, 1), "\x{F3}"); 327 328$x = "\xF1\xF2\xF3"; 329substr($x, 0, 1) = "\x{100}\x{FF}"; # Ignasi had \x{FF} 330is(length($x), 4); 331is($x, "\x{100}\x{FF}\xF2\xF3"); 332is(substr($x, 0, 1), "\x{100}"); 333is(substr($x, 1, 1), "\x{FF}"); 334is(substr($x, 2, 1), "\x{F2}"); 335is(substr($x, 3, 1), "\x{F3}"); 336 337# more utf8 lval exercise 338 339$x = "\xF1\xF2\xF3"; 340substr($x, 0, 2) = "\x{100}\xFF"; 341is(length($x), 3); 342is($x, "\x{100}\xFF\xF3"); 343is(substr($x, 0, 1), "\x{100}"); 344is(substr($x, 1, 1), "\x{FF}"); 345is(substr($x, 2, 1), "\x{F3}"); 346 347$x = "\xF1\xF2\xF3"; 348substr($x, 1, 1) = "\x{100}\xFF"; 349is(length($x), 4); 350is($x, "\xF1\x{100}\xFF\xF3"); 351is(substr($x, 0, 1), "\x{F1}"); 352is(substr($x, 1, 1), "\x{100}"); 353is(substr($x, 2, 1), "\x{FF}"); 354is(substr($x, 3, 1), "\x{F3}"); 355 356$x = "\xF1\xF2\xF3"; 357substr($x, 2, 1) = "\x{100}\xFF"; 358is(length($x), 4); 359is($x, "\xF1\xF2\x{100}\xFF"); 360is(substr($x, 0, 1), "\x{F1}"); 361is(substr($x, 1, 1), "\x{F2}"); 362is(substr($x, 2, 1), "\x{100}"); 363is(substr($x, 3, 1), "\x{FF}"); 364 365$x = "\xF1\xF2\xF3"; 366substr($x, 3, 1) = "\x{100}\xFF"; 367is(length($x), 5); 368is($x, "\xF1\xF2\xF3\x{100}\xFF"); 369is(substr($x, 0, 1), "\x{F1}"); 370is(substr($x, 1, 1), "\x{F2}"); 371is(substr($x, 2, 1), "\x{F3}"); 372is(substr($x, 3, 1), "\x{100}"); 373is(substr($x, 4, 1), "\x{FF}"); 374 375$x = "\xF1\xF2\xF3"; 376substr($x, -1, 1) = "\x{100}\xFF"; 377is(length($x), 4); 378is($x, "\xF1\xF2\x{100}\xFF"); 379is(substr($x, 0, 1), "\x{F1}"); 380is(substr($x, 1, 1), "\x{F2}"); 381is(substr($x, 2, 1), "\x{100}"); 382is(substr($x, 3, 1), "\x{FF}"); 383 384$x = "\xF1\xF2\xF3"; 385substr($x, -1, 0) = "\x{100}\xFF"; 386is(length($x), 5); 387is($x, "\xF1\xF2\x{100}\xFF\xF3"); 388is(substr($x, 0, 1), "\x{F1}"); 389is(substr($x, 1, 1), "\x{F2}"); 390is(substr($x, 2, 1), "\x{100}"); 391is(substr($x, 3, 1), "\x{FF}"); 392is(substr($x, 4, 1), "\x{F3}"); 393 394$x = "\xF1\xF2\xF3"; 395substr($x, 0, -1) = "\x{100}\xFF"; 396is(length($x), 3); 397is($x, "\x{100}\xFF\xF3"); 398is(substr($x, 0, 1), "\x{100}"); 399is(substr($x, 1, 1), "\x{FF}"); 400is(substr($x, 2, 1), "\x{F3}"); 401 402$x = "\xF1\xF2\xF3"; 403substr($x, 0, -2) = "\x{100}\xFF"; 404is(length($x), 4); 405is($x, "\x{100}\xFF\xF2\xF3"); 406is(substr($x, 0, 1), "\x{100}"); 407is(substr($x, 1, 1), "\x{FF}"); 408is(substr($x, 2, 1), "\x{F2}"); 409is(substr($x, 3, 1), "\x{F3}"); 410 411$x = "\xF1\xF2\xF3"; 412substr($x, 0, -3) = "\x{100}\xFF"; 413is(length($x), 5); 414is($x, "\x{100}\xFF\xF1\xF2\xF3"); 415is(substr($x, 0, 1), "\x{100}"); 416is(substr($x, 1, 1), "\x{FF}"); 417is(substr($x, 2, 1), "\x{F1}"); 418is(substr($x, 3, 1), "\x{F2}"); 419is(substr($x, 4, 1), "\x{F3}"); 420 421$x = "\xF1\xF2\xF3"; 422substr($x, 1, -1) = "\x{100}\xFF"; 423is(length($x), 4); 424is($x, "\xF1\x{100}\xFF\xF3"); 425is(substr($x, 0, 1), "\x{F1}"); 426is(substr($x, 1, 1), "\x{100}"); 427is(substr($x, 2, 1), "\x{FF}"); 428is(substr($x, 3, 1), "\x{F3}"); 429 430$x = "\xF1\xF2\xF3"; 431substr($x, -1, -1) = "\x{100}\xFF"; 432is(length($x), 5); 433is($x, "\xF1\xF2\x{100}\xFF\xF3"); 434is(substr($x, 0, 1), "\x{F1}"); 435is(substr($x, 1, 1), "\x{F2}"); 436is(substr($x, 2, 1), "\x{100}"); 437is(substr($x, 3, 1), "\x{FF}"); 438is(substr($x, 4, 1), "\x{F3}"); 439 440# And tests for already-UTF8 one 441 442$x = "\x{101}\x{F2}\x{F3}"; 443substr($x, 0, 1) = "\x{100}"; 444is(length($x), 3); 445is($x, "\x{100}\xF2\xF3"); 446is(substr($x, 0, 1), "\x{100}"); 447is(substr($x, 1, 1), "\x{F2}"); 448is(substr($x, 2, 1), "\x{F3}"); 449 450$x = "\x{101}\x{F2}\x{F3}"; 451substr($x, 0, 1) = "\x{100}\x{FF}"; 452is(length($x), 4); 453is($x, "\x{100}\x{FF}\xF2\xF3"); 454is(substr($x, 0, 1), "\x{100}"); 455is(substr($x, 1, 1), "\x{FF}"); 456is(substr($x, 2, 1), "\x{F2}"); 457is(substr($x, 3, 1), "\x{F3}"); 458 459$x = "\x{101}\x{F2}\x{F3}"; 460substr($x, 0, 2) = "\x{100}\xFF"; 461is(length($x), 3); 462is($x, "\x{100}\xFF\xF3"); 463is(substr($x, 0, 1), "\x{100}"); 464is(substr($x, 1, 1), "\x{FF}"); 465is(substr($x, 2, 1), "\x{F3}"); 466 467$x = "\x{101}\x{F2}\x{F3}"; 468substr($x, 1, 1) = "\x{100}\xFF"; 469is(length($x), 4); 470is($x, "\x{101}\x{100}\xFF\xF3"); 471is(substr($x, 0, 1), "\x{101}"); 472is(substr($x, 1, 1), "\x{100}"); 473is(substr($x, 2, 1), "\x{FF}"); 474is(substr($x, 3, 1), "\x{F3}"); 475 476$x = "\x{101}\x{F2}\x{F3}"; 477substr($x, 2, 1) = "\x{100}\xFF"; 478is(length($x), 4); 479is($x, "\x{101}\xF2\x{100}\xFF"); 480is(substr($x, 0, 1), "\x{101}"); 481is(substr($x, 1, 1), "\x{F2}"); 482is(substr($x, 2, 1), "\x{100}"); 483is(substr($x, 3, 1), "\x{FF}"); 484 485$x = "\x{101}\x{F2}\x{F3}"; 486substr($x, 3, 1) = "\x{100}\xFF"; 487is(length($x), 5); 488is($x, "\x{101}\x{F2}\x{F3}\x{100}\xFF"); 489is(substr($x, 0, 1), "\x{101}"); 490is(substr($x, 1, 1), "\x{F2}"); 491is(substr($x, 2, 1), "\x{F3}"); 492is(substr($x, 3, 1), "\x{100}"); 493is(substr($x, 4, 1), "\x{FF}"); 494 495$x = "\x{101}\x{F2}\x{F3}"; 496substr($x, -1, 1) = "\x{100}\xFF"; 497is(length($x), 4); 498is($x, "\x{101}\xF2\x{100}\xFF"); 499is(substr($x, 0, 1), "\x{101}"); 500is(substr($x, 1, 1), "\x{F2}"); 501is(substr($x, 2, 1), "\x{100}"); 502is(substr($x, 3, 1), "\x{FF}"); 503 504$x = "\x{101}\x{F2}\x{F3}"; 505substr($x, -1, 0) = "\x{100}\xFF"; 506is(length($x), 5); 507is($x, "\x{101}\xF2\x{100}\xFF\xF3"); 508is(substr($x, 0, 1), "\x{101}"); 509is(substr($x, 1, 1), "\x{F2}"); 510is(substr($x, 2, 1), "\x{100}"); 511is(substr($x, 3, 1), "\x{FF}"); 512is(substr($x, 4, 1), "\x{F3}"); 513 514$x = "\x{101}\x{F2}\x{F3}"; 515substr($x, 0, -1) = "\x{100}\xFF"; 516is(length($x), 3); 517is($x, "\x{100}\xFF\xF3"); 518is(substr($x, 0, 1), "\x{100}"); 519is(substr($x, 1, 1), "\x{FF}"); 520is(substr($x, 2, 1), "\x{F3}"); 521 522$x = "\x{101}\x{F2}\x{F3}"; 523substr($x, 0, -2) = "\x{100}\xFF"; 524is(length($x), 4); 525is($x, "\x{100}\xFF\xF2\xF3"); 526is(substr($x, 0, 1), "\x{100}"); 527is(substr($x, 1, 1), "\x{FF}"); 528is(substr($x, 2, 1), "\x{F2}"); 529is(substr($x, 3, 1), "\x{F3}"); 530 531$x = "\x{101}\x{F2}\x{F3}"; 532substr($x, 0, -3) = "\x{100}\xFF"; 533is(length($x), 5); 534is($x, "\x{100}\xFF\x{101}\x{F2}\x{F3}"); 535is(substr($x, 0, 1), "\x{100}"); 536is(substr($x, 1, 1), "\x{FF}"); 537is(substr($x, 2, 1), "\x{101}"); 538is(substr($x, 3, 1), "\x{F2}"); 539is(substr($x, 4, 1), "\x{F3}"); 540 541$x = "\x{101}\x{F2}\x{F3}"; 542substr($x, 1, -1) = "\x{100}\xFF"; 543is(length($x), 4); 544is($x, "\x{101}\x{100}\xFF\xF3"); 545is(substr($x, 0, 1), "\x{101}"); 546is(substr($x, 1, 1), "\x{100}"); 547is(substr($x, 2, 1), "\x{FF}"); 548is(substr($x, 3, 1), "\x{F3}"); 549 550$x = "\x{101}\x{F2}\x{F3}"; 551substr($x, -1, -1) = "\x{100}\xFF"; 552is(length($x), 5); 553is($x, "\x{101}\xF2\x{100}\xFF\xF3"); 554is(substr($x, 0, 1), "\x{101}"); 555is(substr($x, 1, 1), "\x{F2}"); 556is(substr($x, 2, 1), "\x{100}"); 557is(substr($x, 3, 1), "\x{FF}"); 558is(substr($x, 4, 1), "\x{F3}"); 559 560substr($x = "ab", 0, 0, "\x{100}\x{200}"); 561is($x, "\x{100}\x{200}ab"); 562 563substr($x = "\x{100}\x{200}", 0, 0, "ab"); 564is($x, "ab\x{100}\x{200}"); 565 566substr($x = "ab", 1, 0, "\x{100}\x{200}"); 567is($x, "a\x{100}\x{200}b"); 568 569substr($x = "\x{100}\x{200}", 1, 0, "ab"); 570is($x, "\x{100}ab\x{200}"); 571 572substr($x = "ab", 2, 0, "\x{100}\x{200}"); 573is($x, "ab\x{100}\x{200}"); 574 575substr($x = "\x{100}\x{200}", 2, 0, "ab"); 576is($x, "\x{100}\x{200}ab"); 577 578substr($x = "\xFFb", 0, 0, "\x{100}\x{200}"); 579is($x, "\x{100}\x{200}\xFFb"); 580 581substr($x = "\x{100}\x{200}", 0, 0, "\xFFb"); 582is($x, "\xFFb\x{100}\x{200}"); 583 584substr($x = "\xFFb", 1, 0, "\x{100}\x{200}"); 585is($x, "\xFF\x{100}\x{200}b"); 586 587substr($x = "\x{100}\x{200}", 1, 0, "\xFFb"); 588is($x, "\x{100}\xFFb\x{200}"); 589 590substr($x = "\xFFb", 2, 0, "\x{100}\x{200}"); 591is($x, "\xFFb\x{100}\x{200}"); 592 593substr($x = "\x{100}\x{200}", 2, 0, "\xFFb"); 594is($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 722SKIP: { 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 757ok 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. 792package o { 793 use overload '""' => sub { ++our $count; $_[0][0] } 794} 795my $refee = bless ["\x{100}a"], o::; 796my $substr = \substr $refee, -2; # UTF8 flag still off for $$substr. 797$$substr = "b"; # UTF8 flag turns on when setsubstr 798is $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: 804my $string = $refee; $string = "$string"; 805substr $refee, 0, 0, "\xff"; 806is $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 810bless $refee, "\xff"; 811$string = $refee; $string = "$string"; 812substr $refee, 0, 0, "\xff"; 813is $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; 819substr $refee, 0, 0, ""; 820is $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; 825is $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::; 829is $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 845my $destroyed; 846{ package Class; DESTROY { ++$destroyed; } } 847 848$destroyed = 0; 849{ 850 my $x = ''; 851 substr($x,0,1) = ""; 852 $x = bless({}, 'Class'); 853} 854is($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 874fresh_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 9211; 922