t/op/substr.t

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