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