Make 4-arg substr check SvUTF8(target) after stringfying
[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     @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(385);
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 }
820
821 # Test that UTF8-ness of magic var changing does not confuse substr lvalue
822 # assignment.
823 # We use overloading for our magic var, but a typeglob would work, too.
824 package o {
825     use overload '""' => sub { ++our $count; $_[0][0] }
826 }
827 my $refee = bless ["\x{100}a"], o::;
828 my $substr = \substr $refee, -2;        # UTF8 flag still off for $$substr.
829 $$substr = "b";                         # UTF8 flag turns on when setsubstr
830 is $refee, "b",                         # magic stringifies $$substr.
831      'substr lvalue assignment when stringification turns on UTF8ness';
832
833 # Test that changing UTF8-ness does not confuse 4-arg substr.
834 $refee = bless [], "\x{100}a";
835 # stringify without returning on UTF8 flag on $refee:
836 my $string = $refee; $string = "$string";
837 substr $refee, 0, 0, "\xff";
838 is $refee, "\xff$string",
839   '4-arg substr with target UTF8ness turning on when stringified';
840 $refee = bless [], "\x{100}";
841 () = "$refee"; # UTF8 flag now on
842 bless $refee, "\xff";
843 $string = $refee; $string = "$string";
844 substr $refee, 0, 0, "\xff";
845 is $refee, "\xff$string",
846   '4-arg substr with target UTF8ness turning off when stringified';
847
848 # Overload count
849 $refee = bless ["foo"], o::;
850 $o::count = 0;
851 substr $refee, 0, 0, "";
852 is $o::count, 1, '4-arg substr calls overloading once on the target';