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     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(390);
  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 #23765]
 715 {
 716     my $a = pack("C", 0xbf);
 717     no warnings 'deprecated';
 718     substr($a, -1) &= chr(0xfeff);
 719     is($a, "\xbf");
 720 }
 721
 722 # [perl #34976] incorrect caching of utf8 substr length
 723 {
 724     my  $a = "abcd\x{100}";
 725     is(substr($a,1,2), 'bc');
 726     is(substr($a,1,1), 'b');
 727 }
 728
 729 # [perl #62646] offsets exceeding 32 bits on 64-bit system
 730 SKIP: {
 731     skip("32-bit system", 24) unless ~0 > 0xffffffff;
 732     my $a = "abc";
 733     my $s;
 734     my $r;
 735
 736     utf8::downgrade($a);
 737     for (1..2) {
 738         $w = 0;
 739         $r = substr($a, 0xffffffff, 1);
 740         is($r, undef);
 741         is($w, 1);
 742
 743         $w = 0;
 744         $r = substr($a, 0xffffffff+1, 1);
 745         is($r, undef);
 746         is($w, 1);
 747
 748         $w = 0;
 749         ok( !eval { $r = substr($s=$a, 0xffffffff, 1, "_"); 1 } );
 750         is($r, undef);
 751         is($s, $a);
 752         is($w, 0);
 753
 754         $w = 0;
 755         ok( !eval { $r = substr($s=$a, 0xffffffff+1, 1, "_"); 1 } );
 756         is($r, undef);
 757         is($s, $a);
 758         is($w, 0);
 759
 760         utf8::upgrade($a);
 761     }
 762 }
 763
 764 # [perl #77692] UTF8 cache not being reset when TARG is reused
 765 ok eval {
 766  local ${^UTF8CACHE} = -1;
 767  for my $i (0..1)
 768  {
 769    my $dummy = length(substr("\x{100}",0,$i));
 770  }
 771  1
 772 }, 'UTF8 cache is reset when TARG is reused [perl #77692]';
 773
 774 {
 775     use utf8;
 776     use open qw( :utf8 :std );
 777     no warnings 'once';
 778
 779     my $t = "";
 780     substr $t, 0, 0, *ワルド;
 781     is($t, "*main::ワルド", "substr works on UTF-8 globs");
 782
 783     $t = "The World!";
 784     substr $t, 0, 9, *ザ::ワルド;
 785     is($t, "*ザ::ワルド!", "substr works on a UTF-8 glob + stash");
 786 }
 787
 788 {
 789     my $x = *foo;
 790     my $y = \substr *foo, 0, 0;
 791     is ref \$x, 'GLOB', '\substr does not coerce its glob arg just yet';
 792     $x = \"foo";
 793     $y = \substr *foo, 0, 0;
 794     is ref \$x, 'REF', '\substr does not coerce its ref arg just yet';
 795 }
 796
 797 # Test that UTF8-ness of magic var changing does not confuse substr lvalue
 798 # assignment.
 799 # We use overloading for our magic var, but a typeglob would work, too.
 800 package o {
 801     use overload '""' => sub { ++our $count; $_[0][0] }
 802 }
 803 my $refee = bless ["\x{100}a"], o::;
 804 my $substr = \substr $refee, -2;        # UTF8 flag still off for $$substr.
 805 $$substr = "b";                         # UTF8 flag turns on when setsubstr
 806 is $refee, "b",                         # magic stringifies $$substr.
 807      'substr lvalue assignment when stringification turns on UTF8ness';
 808
 809 # Test that changing UTF8-ness does not confuse 4-arg substr.
 810 $refee = bless [], "\x{100}a";
 811 # stringify without returning on UTF8 flag on $refee:
 812 my $string = $refee; $string = "$string";
 813 substr $refee, 0, 0, "\xff";
 814 is $refee, "\xff$string",
 815   '4-arg substr with target UTF8ness turning on when stringified';
 816 $refee = bless [], "\x{100}";
 817 () = "$refee"; # UTF8 flag now on
 818 bless $refee, "\xff";
 819 $string = $refee; $string = "$string";
 820 substr $refee, 0, 0, "\xff";
 821 is $refee, "\xff$string",
 822   '4-arg substr with target UTF8ness turning off when stringified';
 823
 824 # Overload count
 825 $refee = bless ["foo"], o::;
 826 $o::count = 0;
 827 substr $refee, 0, 0, "";
 828 is $o::count, 1, '4-arg substr calls overloading once on the target';
 829 $refee = bless ["\x{100}"], o::;
 830 () = "$refee"; # turn UTF8 flag on
 831 $o::count = 0;
 832 () = substr $refee, 0;
 833 is $o::count, 1, 'rvalue substr calls overloading once on utf8 target';
 834 $o::count = 0;
 835 $refee = "";
 836 ${\substr $refee, 0} = bless ["\x{100}"], o::;
 837 is $o::count, 1, 'assigning utf8 overload to substr lvalue calls ovld 1ce';
 838
 839 # [perl #7678] core dump with substr reference and localisation
 840 {$b="abcde"; local $k; *k=\substr($b, 2, 1);}
 841
 842 # [perl #128260] assertion failure with \substr %h, \substr @h
 843 {
 844     my %h = 1..100;
 845     my @a = 1..100;
 846     is ${\substr %h, 0}, scalar %h, '\substr %h';
 847     is ${\substr @a, 0}, scalar @a, '\substr @a';
 848 }
 849
 850 } # sub run_tests - put tests above this line that can run in threads
 851
 852
 853 my $destroyed;
 854 { package Class; DESTROY { ++$destroyed; } }
 855
 856 $destroyed = 0;
 857 {
 858     my $x = '';
 859     substr($x,0,1) = "";
 860     $x = bless({}, 'Class');
 861 }
 862 is($destroyed, 1, 'Timely scalar destruction with lvalue substr');
 863
 864 {
 865     my $result_3363;
 866     sub a_3363 {
 867         my ($word, $replace) = @_;
 868         my $ref = \substr($word, 0, 1);
 869         $$ref = $replace;
 870         if ($replace eq "b") {
 871             $result_3363 = $word;
 872         } else {
 873             a_3363($word, "b");
 874         }
 875     }
 876     a_3363($_, "v") for "test";
 877
 878     is($result_3363, "best", "ref-to-substr retains lvalue-ness under recursion [perl #3363]");
 879 }