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