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