t/re/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 no warnings 'deprecated';
  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 require './test.pl';
  26
  27 plan(361);
  28
  29 run_tests() unless caller;
  30
  31 my $krunch = "a";
  32
  33 sub run_tests {
  34
  35 $FATAL_MSG = qr/^substr outside of string/;
  36
  37 is(substr($a,0,3), 'abc');   # P=Q R S
  38 is(substr($a,3,3), 'def');   # P Q R S
  39 is(substr($a,6,999), 'xyz'); # P Q S R
  40 $b = substr($a,999,999) ; # warn # P R Q S
  41 is ($w--, 1);
  42 eval{substr($a,999,999) = "" ; };# P R Q S
  43 like ($@, $FATAL_MSG);
  44 is(substr($a,0,-6), 'abc');  # P=Q R S
  45 is(substr($a,-3,1), 'x');    # P Q R S
  46
  47 $[ = 1;
  48
  49 is(substr($a,1,3), 'abc' );  # P=Q R S
  50 is(substr($a,4,3), 'def' );  # P Q R S
  51 is(substr($a,7,999), 'xyz');# P Q S R
  52 $b = substr($a,999,999) ; # warn # P R Q S
  53 is($w--, 1);
  54 eval{substr($a,999,999) = "" ; } ; # P R Q S
  55 like ($@, $FATAL_MSG);
  56 is(substr($a,1,-6), 'abc' );# P=Q R S
  57 is(substr($a,-3,1), 'x' );  # P Q R S
  58
  59 $[ = 0;
  60
  61 substr($a,3,3) = 'XYZ';
  62 is($a, 'abcXYZxyz' );
  63 substr($a,0,2) = '';
  64 is($a, 'cXYZxyz' );
  65 substr($a,0,0) = 'ab';
  66 is($a, 'abcXYZxyz' );
  67 substr($a,0,0) = '12345678';
  68 is($a, '12345678abcXYZxyz' );
  69 substr($a,-3,3) = 'def';
  70 is($a, '12345678abcXYZdef');
  71 substr($a,-3,3) = '<';
  72 is($a, '12345678abcXYZ<' );
  73 substr($a,-1,1) = '12345678';
  74 is($a, '12345678abcXYZ12345678' );
  75
  76 $a = 'abcdefxyz';
  77
  78 is(substr($a,6), 'xyz' );        # P Q R=S
  79 is(substr($a,-3), 'xyz' );       # P Q R=S
  80 $b = substr($a,999,999) ; # warning   # P R=S Q
  81 is($w--, 1);
  82 eval{substr($a,999,999) = "" ; } ;    # P R=S Q
  83 like($@, $FATAL_MSG);
  84 is(substr($a,0), 'abcdefxyz');  # P=Q R=S
  85 is(substr($a,9), '');           # P Q=R=S
  86 is(substr($a,-11), 'abcdefxyz'); # Q P R=S
  87 is(substr($a,-9), 'abcdefxyz');  # P=Q R=S
  88
  89 $a = '54321';
  90
  91 $b = substr($a,-7, 1) ; # warn  # Q R P S
  92 is($w--, 1);
  93 eval{substr($a,-7, 1) = "" ; }; # Q R P S
  94 like($@, $FATAL_MSG);
  95 $b = substr($a,-7,-6) ; # warn  # Q R P S
  96 is($w--, 1);
  97 eval{substr($a,-7,-6) = "" ; }; # Q R P S
  98 like($@, $FATAL_MSG);
  99 is(substr($a,-5,-7), '');  # R P=Q S
 100 is(substr($a, 2,-7), '');  # R P Q S
 101 is(substr($a,-3,-7), '');  # R P Q S
 102 is(substr($a, 2,-5), '');  # P=R Q S
 103 is(substr($a,-3,-5), '');  # P=R Q S
 104 is(substr($a, 2,-4), '');  # P R Q S
 105 is(substr($a,-3,-4), '');  # P R Q S
 106 is(substr($a, 5,-6), '');  # R P Q=S
 107 is(substr($a, 5,-5), '');  # P=R Q S
 108 is(substr($a, 5,-3), '');  # P R Q=S
 109 $b = substr($a, 7,-7) ; # warn  # R P S Q
 110 is($w--, 1);
 111 eval{substr($a, 7,-7) = "" ; }; # R P S Q
 112 like($@, $FATAL_MSG);
 113 $b = substr($a, 7,-5) ; # warn  # P=R S Q
 114 is($w--, 1);
 115 eval{substr($a, 7,-5) = "" ; }; # P=R S Q
 116 like($@, $FATAL_MSG);
 117 $b = substr($a, 7,-3) ; # warn  # P Q S Q
 118 is($w--, 1);
 119 eval{substr($a, 7,-3) = "" ; }; # P Q S Q
 120 like($@, $FATAL_MSG);
 121 $b = substr($a, 7, 0) ; # warn  # P S Q=R
 122 is($w--, 1);
 123 eval{substr($a, 7, 0) = "" ; }; # P S Q=R
 124 like($@, $FATAL_MSG);
 125
 126 is(substr($a,-7,2), '');   # Q P=R S
 127 is(substr($a,-7,4), '54'); # Q P R S
 128 is(substr($a,-7,7), '54321');# Q P R=S
 129 is(substr($a,-7,9), '54321');# Q P S R
 130 is(substr($a,-5,0), '');   # P=Q=R S
 131 is(substr($a,-5,3), '543');# P=Q R S
 132 is(substr($a,-5,5), '54321');# P=Q R=S
 133 is(substr($a,-5,7), '54321');# P=Q S R
 134 is(substr($a,-3,0), '');   # P Q=R S
 135 is(substr($a,-3,3), '321');# P Q R=S
 136 is(substr($a,-2,3), '21'); # P Q S R
 137 is(substr($a,0,-5), '');   # P=Q=R S
 138 is(substr($a,2,-3), '');   # P Q=R S
 139 is(substr($a,0,0), '');    # P=Q=R S
 140 is(substr($a,0,5), '54321');# P=Q R=S
 141 is(substr($a,0,7), '54321');# P=Q S R
 142 is(substr($a,2,0), '');    # P Q=R S
 143 is(substr($a,2,3), '321'); # P Q R=S
 144 is(substr($a,5,0), '');    # P Q=R=S
 145 is(substr($a,5,2), '');    # P Q=S R
 146 is(substr($a,-7,-5), '');  # Q P=R S
 147 is(substr($a,-7,-2), '543');# Q P R S
 148 is(substr($a,-5,-5), '');  # P=Q=R S
 149 is(substr($a,-5,-2), '543');# P=Q R S
 150 is(substr($a,-3,-3), '');  # P Q=R S
 151 is(substr($a,-3,-1), '32');# P Q R S
 152
 153 $a = '';
 154
 155 is(substr($a,-2,2), '');   # Q P=R=S
 156 is(substr($a,0,0), '');    # P=Q=R=S
 157 is(substr($a,0,1), '');    # P=Q=S R
 158 is(substr($a,-2,3), '');   # Q P=S R
 159 is(substr($a,-2), '');     # Q P=R=S
 160 is(substr($a,0), '');      # P=Q=R=S
 161
 162
 163 is(substr($a,0,-1), '');   # R P=Q=S
 164 $b = substr($a,-2, 0) ; # warn  # Q=R P=S
 165 is($w--, 1);
 166 eval{substr($a,-2, 0) = "" ; }; # Q=R P=S
 167 like($@, $FATAL_MSG);
 168
 169 $b = substr($a,-2, 1) ; # warn  # Q R P=S
 170 is($w--, 1);
 171 eval{substr($a,-2, 1) = "" ; }; # Q R P=S
 172 like($@, $FATAL_MSG);
 173
 174 $b = substr($a,-2,-1) ; # warn  # Q R P=S
 175 is($w--, 1);
 176 eval{substr($a,-2,-1) = "" ; }; # Q R P=S
 177 like($@, $FATAL_MSG);
 178
 179 $b = substr($a,-2,-2) ; # warn  # Q=R P=S
 180 is($w--, 1);
 181 eval{substr($a,-2,-2) = "" ; }; # Q=R P=S
 182 like($@, $FATAL_MSG);
 183
 184 $b = substr($a, 1,-2) ; # warn  # R P=S Q
 185 is($w--, 1);
 186 eval{substr($a, 1,-2) = "" ; }; # R P=S Q
 187 like($@, $FATAL_MSG);
 188
 189 $b = substr($a, 1, 1) ; # warn  # P=S Q R
 190 is($w--, 1);
 191 eval{substr($a, 1, 1) = "" ; }; # P=S Q R
 192 like($@, $FATAL_MSG);
 193
 194 $b = substr($a, 1, 0) ;# warn   # P=S Q=R
 195 is($w--, 1);
 196 eval{substr($a, 1, 0) = "" ; }; # P=S Q=R
 197 like($@, $FATAL_MSG);
 198
 199 $b = substr($a,1) ; # warning   # P=R=S Q
 200 is($w--, 1);
 201 eval{substr($a,1) = "" ; };     # P=R=S Q
 202 like($@, $FATAL_MSG);
 203
 204 $b = substr($a,-7,-6) ; # warn  # Q R P S
 205 is($w--, 1);
 206 eval{substr($a,-7,-6) = "" ; }; # Q R P S
 207 like($@, $FATAL_MSG);
 208
 209 my $a = 'zxcvbnm';
 210 substr($a,2,0) = '';
 211 is($a, 'zxcvbnm');
 212 substr($a,7,0) = '';
 213 is($a, 'zxcvbnm');
 214 substr($a,5,0) = '';
 215 is($a, 'zxcvbnm');
 216 substr($a,0,2) = 'pq';
 217 is($a, 'pqcvbnm');
 218 substr($a,2,0) = 'r';
 219 is($a, 'pqrcvbnm');
 220 substr($a,8,0) = 'asd';
 221 is($a, 'pqrcvbnmasd');
 222 substr($a,0,2) = 'iop';
 223 is($a, 'ioprcvbnmasd');
 224 substr($a,0,5) = 'fgh';
 225 is($a, 'fghvbnmasd');
 226 substr($a,3,5) = 'jkl';
 227 is($a, 'fghjklsd');
 228 substr($a,3,2) = '1234';
 229 is($a, 'fgh1234lsd');
 230
 231
 232 # with lexicals (and in re-entered scopes)
 233 for (0,1) {
 234   my $txt;
 235   unless ($_) {
 236     $txt = "Foo";
 237     substr($txt, -1) = "X";
 238     is($txt, "FoX");
 239   }
 240   else {
 241     substr($txt, 0, 1) = "X";
 242     is($txt, "X");
 243   }
 244 }
 245
 246 $w = 0 ;
 247 # coercion of references
 248 {
 249   my $s = [];
 250   substr($s, 0, 1) = 'Foo';
 251   is (substr($s,0,7), "FooRRAY");
 252   is ($w,2);
 253   $w = 0;
 254 }
 255
 256 # check no spurious warnings
 257 is($w, 0);
 258
 259 # check new 4 arg replacement syntax
 260 $a = "abcxyz";
 261 $w = 0;
 262 is(substr($a, 0, 3, ""), "abc");
 263 is($a, "xyz");
 264 is(substr($a, 0, 0, "abc"), "");
 265 is($a, "abcxyz");
 266 is(substr($a, 3, -1, ""), "xy");
 267 is($a, "abcz");
 268
 269 is(substr($a, 3, undef, "xy"), "");
 270 is($a, "abcxyz");
 271 is($w, 3);
 272
 273 $w = 0;
 274
 275 is(substr($a, 3, 9999999, ""), "xyz");
 276 is($a, "abc");
 277 eval{substr($a, -99, 0, "") };
 278 like($@, $FATAL_MSG);
 279 eval{substr($a, 99, 3, "") };
 280 like($@, $FATAL_MSG);
 281
 282 substr($a, 0, length($a), "foo");
 283 is ($a, "foo");
 284 is ($w, 0);
 285
 286 # using 4 arg substr as lvalue is a compile time error
 287 eval 'substr($a,0,0,"") = "abc"';
 288 like ($@, qr/Can't modify substr/);
 289 is ($a, "foo");
 290
 291 $a = "abcdefgh";
 292 is(sub { shift }->(substr($a, 0, 4, "xxxx")), 'abcd');
 293 is($a, 'xxxxefgh');
 294
 295 {
 296     my $y = 10;
 297     $y = "2" . $y;
 298     is ($y, 210);
 299 }
 300
 301 # utf8 sanity
 302 {
 303     my $x = substr("a\x{263a}b",0);
 304     is(length($x), 3);
 305     $x = substr($x,1,1);
 306     is($x, "\x{263a}");
 307     $x = $x x 2;
 308     is(length($x), 2);
 309     substr($x,0,1) = "abcd";
 310     is($x, "abcd\x{263a}");
 311     is(length($x), 5);
 312     $x = reverse $x;
 313     is(length($x), 5);
 314     is($x, "\x{263a}dcba");
 315
 316     my $z = 10;
 317     $z = "21\x{263a}" . $z;
 318     is(length($z), 5);
 319     is($z, "21\x{263a}10");
 320 }
 321
 322 # replacement should work on magical values
 323 require Tie::Scalar;
 324 my %data;
 325 tie $data{'a'}, 'Tie::StdScalar';  # makes $data{'a'} magical
 326 $data{a} = "firstlast";
 327 is(substr($data{'a'}, 0, 5, ""), "first");
 328 is($data{'a'}, "last");
 329
 330 # more utf8
 331
 332 # The following two originally from Ignasi Roca.
 333
 334 $x = "\xF1\xF2\xF3";
 335 substr($x, 0, 1) = "\x{100}"; # Ignasi had \x{FF}
 336 is(length($x), 3);
 337 is($x, "\x{100}\xF2\xF3");
 338 is(substr($x, 0, 1), "\x{100}");
 339 is(substr($x, 1, 1), "\x{F2}");
 340 is(substr($x, 2, 1), "\x{F3}");
 341
 342 $x = "\xF1\xF2\xF3";
 343 substr($x, 0, 1) = "\x{100}\x{FF}"; # Ignasi had \x{FF}
 344 is(length($x), 4);
 345 is($x, "\x{100}\x{FF}\xF2\xF3");
 346 is(substr($x, 0, 1), "\x{100}");
 347 is(substr($x, 1, 1), "\x{FF}");
 348 is(substr($x, 2, 1), "\x{F2}");
 349 is(substr($x, 3, 1), "\x{F3}");
 350
 351 # more utf8 lval exercise
 352
 353 $x = "\xF1\xF2\xF3";
 354 substr($x, 0, 2) = "\x{100}\xFF";
 355 is(length($x), 3);
 356 is($x, "\x{100}\xFF\xF3");
 357 is(substr($x, 0, 1), "\x{100}");
 358 is(substr($x, 1, 1), "\x{FF}");
 359 is(substr($x, 2, 1), "\x{F3}");
 360
 361 $x = "\xF1\xF2\xF3";
 362 substr($x, 1, 1) = "\x{100}\xFF";
 363 is(length($x), 4);
 364 is($x, "\xF1\x{100}\xFF\xF3");
 365 is(substr($x, 0, 1), "\x{F1}");
 366 is(substr($x, 1, 1), "\x{100}");
 367 is(substr($x, 2, 1), "\x{FF}");
 368 is(substr($x, 3, 1), "\x{F3}");
 369
 370 $x = "\xF1\xF2\xF3";
 371 substr($x, 2, 1) = "\x{100}\xFF";
 372 is(length($x), 4);
 373 is($x, "\xF1\xF2\x{100}\xFF");
 374 is(substr($x, 0, 1), "\x{F1}");
 375 is(substr($x, 1, 1), "\x{F2}");
 376 is(substr($x, 2, 1), "\x{100}");
 377 is(substr($x, 3, 1), "\x{FF}");
 378
 379 $x = "\xF1\xF2\xF3";
 380 substr($x, 3, 1) = "\x{100}\xFF";
 381 is(length($x), 5);
 382 is($x, "\xF1\xF2\xF3\x{100}\xFF");
 383 is(substr($x, 0, 1), "\x{F1}");
 384 is(substr($x, 1, 1), "\x{F2}");
 385 is(substr($x, 2, 1), "\x{F3}");
 386 is(substr($x, 3, 1), "\x{100}");
 387 is(substr($x, 4, 1), "\x{FF}");
 388
 389 $x = "\xF1\xF2\xF3";
 390 substr($x, -1, 1) = "\x{100}\xFF";
 391 is(length($x), 4);
 392 is($x, "\xF1\xF2\x{100}\xFF");
 393 is(substr($x, 0, 1), "\x{F1}");
 394 is(substr($x, 1, 1), "\x{F2}");
 395 is(substr($x, 2, 1), "\x{100}");
 396 is(substr($x, 3, 1), "\x{FF}");
 397
 398 $x = "\xF1\xF2\xF3";
 399 substr($x, -1, 0) = "\x{100}\xFF";
 400 is(length($x), 5);
 401 is($x, "\xF1\xF2\x{100}\xFF\xF3");
 402 is(substr($x, 0, 1), "\x{F1}");
 403 is(substr($x, 1, 1), "\x{F2}");
 404 is(substr($x, 2, 1), "\x{100}");
 405 is(substr($x, 3, 1), "\x{FF}");
 406 is(substr($x, 4, 1), "\x{F3}");
 407
 408 $x = "\xF1\xF2\xF3";
 409 substr($x, 0, -1) = "\x{100}\xFF";
 410 is(length($x), 3);
 411 is($x, "\x{100}\xFF\xF3");
 412 is(substr($x, 0, 1), "\x{100}");
 413 is(substr($x, 1, 1), "\x{FF}");
 414 is(substr($x, 2, 1), "\x{F3}");
 415
 416 $x = "\xF1\xF2\xF3";
 417 substr($x, 0, -2) = "\x{100}\xFF";
 418 is(length($x), 4);
 419 is($x, "\x{100}\xFF\xF2\xF3");
 420 is(substr($x, 0, 1), "\x{100}");
 421 is(substr($x, 1, 1), "\x{FF}");
 422 is(substr($x, 2, 1), "\x{F2}");
 423 is(substr($x, 3, 1), "\x{F3}");
 424
 425 $x = "\xF1\xF2\xF3";
 426 substr($x, 0, -3) = "\x{100}\xFF";
 427 is(length($x), 5);
 428 is($x, "\x{100}\xFF\xF1\xF2\xF3");
 429 is(substr($x, 0, 1), "\x{100}");
 430 is(substr($x, 1, 1), "\x{FF}");
 431 is(substr($x, 2, 1), "\x{F1}");
 432 is(substr($x, 3, 1), "\x{F2}");
 433 is(substr($x, 4, 1), "\x{F3}");
 434
 435 $x = "\xF1\xF2\xF3";
 436 substr($x, 1, -1) = "\x{100}\xFF";
 437 is(length($x), 4);
 438 is($x, "\xF1\x{100}\xFF\xF3");
 439 is(substr($x, 0, 1), "\x{F1}");
 440 is(substr($x, 1, 1), "\x{100}");
 441 is(substr($x, 2, 1), "\x{FF}");
 442 is(substr($x, 3, 1), "\x{F3}");
 443
 444 $x = "\xF1\xF2\xF3";
 445 substr($x, -1, -1) = "\x{100}\xFF";
 446 is(length($x), 5);
 447 is($x, "\xF1\xF2\x{100}\xFF\xF3");
 448 is(substr($x, 0, 1), "\x{F1}");
 449 is(substr($x, 1, 1), "\x{F2}");
 450 is(substr($x, 2, 1), "\x{100}");
 451 is(substr($x, 3, 1), "\x{FF}");
 452 is(substr($x, 4, 1), "\x{F3}");
 453
 454 # And tests for already-UTF8 one
 455
 456 $x = "\x{101}\x{F2}\x{F3}";
 457 substr($x, 0, 1) = "\x{100}";
 458 is(length($x), 3);
 459 is($x, "\x{100}\xF2\xF3");
 460 is(substr($x, 0, 1), "\x{100}");
 461 is(substr($x, 1, 1), "\x{F2}");
 462 is(substr($x, 2, 1), "\x{F3}");
 463
 464 $x = "\x{101}\x{F2}\x{F3}";
 465 substr($x, 0, 1) = "\x{100}\x{FF}";
 466 is(length($x), 4);
 467 is($x, "\x{100}\x{FF}\xF2\xF3");
 468 is(substr($x, 0, 1), "\x{100}");
 469 is(substr($x, 1, 1), "\x{FF}");
 470 is(substr($x, 2, 1), "\x{F2}");
 471 is(substr($x, 3, 1), "\x{F3}");
 472
 473 $x = "\x{101}\x{F2}\x{F3}";
 474 substr($x, 0, 2) = "\x{100}\xFF";
 475 is(length($x), 3);
 476 is($x, "\x{100}\xFF\xF3");
 477 is(substr($x, 0, 1), "\x{100}");
 478 is(substr($x, 1, 1), "\x{FF}");
 479 is(substr($x, 2, 1), "\x{F3}");
 480
 481 $x = "\x{101}\x{F2}\x{F3}";
 482 substr($x, 1, 1) = "\x{100}\xFF";
 483 is(length($x), 4);
 484 is($x, "\x{101}\x{100}\xFF\xF3");
 485 is(substr($x, 0, 1), "\x{101}");
 486 is(substr($x, 1, 1), "\x{100}");
 487 is(substr($x, 2, 1), "\x{FF}");
 488 is(substr($x, 3, 1), "\x{F3}");
 489
 490 $x = "\x{101}\x{F2}\x{F3}";
 491 substr($x, 2, 1) = "\x{100}\xFF";
 492 is(length($x), 4);
 493 is($x, "\x{101}\xF2\x{100}\xFF");
 494 is(substr($x, 0, 1), "\x{101}");
 495 is(substr($x, 1, 1), "\x{F2}");
 496 is(substr($x, 2, 1), "\x{100}");
 497 is(substr($x, 3, 1), "\x{FF}");
 498
 499 $x = "\x{101}\x{F2}\x{F3}";
 500 substr($x, 3, 1) = "\x{100}\xFF";
 501 is(length($x), 5);
 502 is($x, "\x{101}\x{F2}\x{F3}\x{100}\xFF");
 503 is(substr($x, 0, 1), "\x{101}");
 504 is(substr($x, 1, 1), "\x{F2}");
 505 is(substr($x, 2, 1), "\x{F3}");
 506 is(substr($x, 3, 1), "\x{100}");
 507 is(substr($x, 4, 1), "\x{FF}");
 508
 509 $x = "\x{101}\x{F2}\x{F3}";
 510 substr($x, -1, 1) = "\x{100}\xFF";
 511 is(length($x), 4);
 512 is($x, "\x{101}\xF2\x{100}\xFF");
 513 is(substr($x, 0, 1), "\x{101}");
 514 is(substr($x, 1, 1), "\x{F2}");
 515 is(substr($x, 2, 1), "\x{100}");
 516 is(substr($x, 3, 1), "\x{FF}");
 517
 518 $x = "\x{101}\x{F2}\x{F3}";
 519 substr($x, -1, 0) = "\x{100}\xFF";
 520 is(length($x), 5);
 521 is($x, "\x{101}\xF2\x{100}\xFF\xF3");
 522 is(substr($x, 0, 1), "\x{101}");
 523 is(substr($x, 1, 1), "\x{F2}");
 524 is(substr($x, 2, 1), "\x{100}");
 525 is(substr($x, 3, 1), "\x{FF}");
 526 is(substr($x, 4, 1), "\x{F3}");
 527
 528 $x = "\x{101}\x{F2}\x{F3}";
 529 substr($x, 0, -1) = "\x{100}\xFF";
 530 is(length($x), 3);
 531 is($x, "\x{100}\xFF\xF3");
 532 is(substr($x, 0, 1), "\x{100}");
 533 is(substr($x, 1, 1), "\x{FF}");
 534 is(substr($x, 2, 1), "\x{F3}");
 535
 536 $x = "\x{101}\x{F2}\x{F3}";
 537 substr($x, 0, -2) = "\x{100}\xFF";
 538 is(length($x), 4);
 539 is($x, "\x{100}\xFF\xF2\xF3");
 540 is(substr($x, 0, 1), "\x{100}");
 541 is(substr($x, 1, 1), "\x{FF}");
 542 is(substr($x, 2, 1), "\x{F2}");
 543 is(substr($x, 3, 1), "\x{F3}");
 544
 545 $x = "\x{101}\x{F2}\x{F3}";
 546 substr($x, 0, -3) = "\x{100}\xFF";
 547 is(length($x), 5);
 548 is($x, "\x{100}\xFF\x{101}\x{F2}\x{F3}");
 549 is(substr($x, 0, 1), "\x{100}");
 550 is(substr($x, 1, 1), "\x{FF}");
 551 is(substr($x, 2, 1), "\x{101}");
 552 is(substr($x, 3, 1), "\x{F2}");
 553 is(substr($x, 4, 1), "\x{F3}");
 554
 555 $x = "\x{101}\x{F2}\x{F3}";
 556 substr($x, 1, -1) = "\x{100}\xFF";
 557 is(length($x), 4);
 558 is($x, "\x{101}\x{100}\xFF\xF3");
 559 is(substr($x, 0, 1), "\x{101}");
 560 is(substr($x, 1, 1), "\x{100}");
 561 is(substr($x, 2, 1), "\x{FF}");
 562 is(substr($x, 3, 1), "\x{F3}");
 563
 564 $x = "\x{101}\x{F2}\x{F3}";
 565 substr($x, -1, -1) = "\x{100}\xFF";
 566 is(length($x), 5);
 567 is($x, "\x{101}\xF2\x{100}\xFF\xF3");
 568 is(substr($x, 0, 1), "\x{101}");
 569 is(substr($x, 1, 1), "\x{F2}");
 570 is(substr($x, 2, 1), "\x{100}");
 571 is(substr($x, 3, 1), "\x{FF}");
 572 is(substr($x, 4, 1), "\x{F3}");
 573
 574 substr($x = "ab", 0, 0, "\x{100}\x{200}");
 575 is($x, "\x{100}\x{200}ab");
 576
 577 substr($x = "\x{100}\x{200}", 0, 0, "ab");
 578 is($x, "ab\x{100}\x{200}");
 579
 580 substr($x = "ab", 1, 0, "\x{100}\x{200}");
 581 is($x, "a\x{100}\x{200}b");
 582
 583 substr($x = "\x{100}\x{200}", 1, 0, "ab");
 584 is($x, "\x{100}ab\x{200}");
 585
 586 substr($x = "ab", 2, 0, "\x{100}\x{200}");
 587 is($x, "ab\x{100}\x{200}");
 588
 589 substr($x = "\x{100}\x{200}", 2, 0, "ab");
 590 is($x, "\x{100}\x{200}ab");
 591
 592 substr($x = "\xFFb", 0, 0, "\x{100}\x{200}");
 593 is($x, "\x{100}\x{200}\xFFb");
 594
 595 substr($x = "\x{100}\x{200}", 0, 0, "\xFFb");
 596 is($x, "\xFFb\x{100}\x{200}");
 597
 598 substr($x = "\xFFb", 1, 0, "\x{100}\x{200}");
 599 is($x, "\xFF\x{100}\x{200}b");
 600
 601 substr($x = "\x{100}\x{200}", 1, 0, "\xFFb");
 602 is($x, "\x{100}\xFFb\x{200}");
 603
 604 substr($x = "\xFFb", 2, 0, "\x{100}\x{200}");
 605 is($x, "\xFFb\x{100}\x{200}");
 606
 607 substr($x = "\x{100}\x{200}", 2, 0, "\xFFb");
 608 is($x, "\x{100}\x{200}\xFFb");
 609
 610 # [perl #20933]
 611 {
 612     my $s = "ab";
 613     my @r;
 614     $r[$_] = \ substr $s, $_, 1 for (0, 1);
 615     is(join("", map { $$_ } @r), "ab");
 616 }
 617
 618 # [perl #23207]
 619 {
 620     sub ss {
 621         substr($_[0],0,1) ^= substr($_[0],1,1) ^=
 622         substr($_[0],0,1) ^= substr($_[0],1,1);
 623     }
 624     my $x = my $y = 'AB'; ss $x; ss $y;
 625     is($x, $y);
 626 }
 627
 628 # [perl #24605]
 629 {
 630     my $x = "0123456789\x{500}";
 631     my $y = substr $x, 4;
 632     is(substr($x, 7, 1), "7");
 633 }
 634
 635 # multiple assignments to lvalue [perl #24346]
 636 {
 637     my $x = "abcdef";
 638     for (substr($x,1,3)) {
 639         is($_, 'bcd');
 640         $_ = 'XX';
 641         is($_, 'XX');
 642         is($x, 'aXXef');
 643         $_ = "\xFF";
 644         is($_, "\xFF");
 645         is($x, "a\xFFef");
 646         $_ = "\xF1\xF2\xF3\xF4\xF5\xF6";
 647         is($_, "\xF1\xF2\xF3\xF4\xF5\xF6");
 648         is($x, "a\xF1\xF2\xF3\xF4\xF5\xF6ef");
 649         $_ = 'YYYY';
 650         is($_, 'YYYY');
 651         is($x, 'aYYYYef');
 652     }
 653 }
 654
 655 # [perl #24200] string corruption with lvalue sub
 656
 657 {
 658     sub bar: lvalue { substr $krunch, 0 }
 659     bar = "XXX";
 660     is(bar, 'XXX');
 661     $krunch = '123456789';
 662     is(bar, '123456789');
 663 }
 664
 665 # [perl #29149]
 666 {
 667     my $text  = "0123456789\xED ";
 668     utf8::upgrade($text);
 669     my $pos = 5;
 670     pos($text) = $pos;
 671     my $a = substr($text, $pos, $pos);
 672     is(substr($text,$pos,1), $pos);
 673
 674 }
 675
 676 # [perl #23765]
 677 {
 678     my $a = pack("C", 0xbf);
 679     substr($a, -1) &= chr(0xfeff);
 680     is($a, "\xbf");
 681 }
 682
 683 # [perl #34976] incorrect caching of utf8 substr length
 684 {
 685     my  $a = "abcd\x{100}";
 686     is(substr($a,1,2), 'bc');
 687     is(substr($a,1,1), 'b');
 688 }
 689
 690 # [perl #62646] offsets exceeding 32 bits on 64-bit system
 691 SKIP: {
 692     skip("32-bit system", 24) unless ~0 > 0xffffffff;
 693     my $a = "abc";
 694     my $s;
 695     my $r;
 696
 697     utf8::downgrade($a);
 698     for (1..2) {
 699         $w = 0;
 700         $r = substr($a, 0xffffffff, 1);
 701         is($r, undef);
 702         is($w, 1);
 703
 704         $w = 0;
 705         $r = substr($a, 0xffffffff+1, 1);
 706         is($r, undef);
 707         is($w, 1);
 708
 709         $w = 0;
 710         ok( !eval { $r = substr($s=$a, 0xffffffff, 1, "_"); 1 } );
 711         is($r, undef);
 712         is($s, $a);
 713         is($w, 0);
 714
 715         $w = 0;
 716         ok( !eval { $r = substr($s=$a, 0xffffffff+1, 1, "_"); 1 } );
 717         is($r, undef);
 718         is($s, $a);
 719         is($w, 0);
 720
 721         utf8::upgrade($a);
 722     }
 723 }
 724
 725 }
 726
 727
 728 my $destroyed;
 729 { package Class; DESTROY { ++$destroyed; } }
 730
 731 $destroyed = 0;
 732 {
 733     my $x = '';
 734     substr($x,0,1) = "";
 735     $x = bless({}, 'Class');
 736 }
 737 is($destroyed, 1, 'Timely scalar destruction with lvalue substr');