This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #129164] Crash with splice
[perl5.git] / t / op / array.t
CommitLineData
a687059c
LW
1#!./perl
2
6b42d12b
DM
3BEGIN {
4 chdir 't' if -d 't';
1ae3d757 5 require './test.pl';
624c42e2 6 set_up_inc('.', '../lib');
6b42d12b
DM
7}
8
a5f48505 9plan (173);
a687059c 10
05fc92f1
GS
11#
12# @foo, @bar, and @ary are also used from tie-stdarray after tie-ing them
13#
14
a687059c 15@ary = (1,2,3,4,5);
0dd3f902 16is(join('',@ary), '12345');
a687059c
LW
17
18$tmp = $ary[$#ary]; --$#ary;
0dd3f902
NC
19is($tmp, 5);
20is($#ary, 3);
21is(join('',@ary), '1234');
a687059c 22
a687059c
LW
23@foo = ();
24$r = join(',', $#foo, @foo);
0dd3f902 25is($r, "-1");
a687059c
LW
26$foo[0] = '0';
27$r = join(',', $#foo, @foo);
0dd3f902 28is($r, "0,0");
a687059c
LW
29$foo[2] = '2';
30$r = join(',', $#foo, @foo);
0dd3f902 31is($r, "2,0,,2");
a687059c
LW
32@bar = ();
33$bar[0] = '0';
34$bar[1] = '1';
35$r = join(',', $#bar, @bar);
0dd3f902 36is($r, "1,0,1");
a687059c
LW
37@bar = ();
38$r = join(',', $#bar, @bar);
0dd3f902 39is($r, "-1");
a687059c
LW
40$bar[0] = '0';
41$r = join(',', $#bar, @bar);
0dd3f902 42is($r, "0,0");
a687059c
LW
43$bar[2] = '2';
44$r = join(',', $#bar, @bar);
0dd3f902 45is($r, "2,0,,2");
14ce8c55 46reset 'b' if $^O ne 'VMS';
a687059c
LW
47@bar = ();
48$bar[0] = '0';
49$r = join(',', $#bar, @bar);
0dd3f902 50is($r, "0,0");
a687059c
LW
51$bar[2] = '2';
52$r = join(',', $#bar, @bar);
0dd3f902 53is($r, "2,0,,2");
a687059c
LW
54
55$foo = 'now is the time';
0dd3f902
NC
56ok(scalar (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/)));
57is($F1, 'now');
58is($F2, 'is');
59is($Etc, 'the time');
a687059c
LW
60
61$foo = 'lskjdf';
0dd3f902
NC
62ok(!($cnt = (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/))))
63 or diag("$cnt $F1:$F2:$Etc");
a687059c
LW
64
65%foo = ('blurfl','dyick','foo','bar','etc.','etc.');
66%bar = %foo;
0dd3f902 67is($bar{'foo'}, 'bar');
a687059c 68%bar = ();
0dd3f902 69is($bar{'foo'}, undef);
a687059c 70(%bar,$a,$b) = (%foo,'how','now');
0dd3f902
NC
71is($bar{'foo'}, 'bar');
72is($bar{'how'}, 'now');
a687059c 73@bar{keys %foo} = values %foo;
0dd3f902
NC
74is($bar{'foo'}, 'bar');
75is($bar{'how'}, 'now');
a687059c
LW
76
77@foo = grep(/e/,split(' ','now is the time for all good men to come to'));
0dd3f902 78is(join(' ',@foo), 'the time men come');
a687059c
LW
79
80@foo = grep(!/e/,split(' ','now is the time for all good men to come to'));
0dd3f902 81is(join(' ',@foo), 'now is for all good to to');
79a0689e
LW
82
83$foo = join('',('a','b','c','d','e','f')[0..5]);
0dd3f902 84is($foo, 'abcdef');
79a0689e
LW
85
86$foo = join('',('a','b','c','d','e','f')[0..1]);
0dd3f902 87is($foo, 'ab');
79a0689e
LW
88
89$foo = join('',('a','b','c','d','e','f')[6]);
0dd3f902 90is($foo, '');
79a0689e
LW
91
92@foo = ('a','b','c','d','e','f')[0,2,4];
93@bar = ('a','b','c','d','e','f')[1,3,5];
94$foo = join('',(@foo,@bar)[0..5]);
0dd3f902 95is($foo, 'acebdf');
79a0689e
LW
96
97$foo = ('a','b','c','d','e','f')[0,2,4];
0dd3f902 98is($foo, 'e');
79a0689e
LW
99
100$foo = ('a','b','c','d','e','f')[1];
0dd3f902 101is($foo, 'b');
a0231f0e 102
b5adc3e5 103@foo = ( 'foo', 'bar', 'burbl', 'blah');
b3381831
GS
104
105# various AASSIGN_COMMON checks (see newASSIGNOP() in op.c)
106
b5adc3e5 107#curr_test(37);
b3381831
GS
108
109@foo = @foo;
b5adc3e5 110is("@foo", "foo bar burbl blah"); # 37
b3381831
GS
111
112(undef,@foo) = @foo;
b5adc3e5 113is("@foo", "bar burbl blah"); # 38
b3381831
GS
114
115@foo = ('XXX',@foo, 'YYY');
b5adc3e5 116is("@foo", "XXX bar burbl blah YYY"); # 39
b3381831 117
3201ebbd 118@foo = @foo = qw(foo b\a\r bu\\rbl blah);
b5adc3e5 119is("@foo", 'foo b\a\r bu\\rbl blah'); # 40
b3381831 120
b5adc3e5 121@bar = @foo = qw(foo bar); # 41
0dd3f902 122is("@foo", "foo bar");
b5adc3e5 123is("@bar", "foo bar"); # 42
b3381831
GS
124
125# try the same with local
05fc92f1
GS
126# XXX tie-stdarray fails the tests involving local, so we use
127# different variable names to escape the 'tie'
128
129@bee = ( 'foo', 'bar', 'burbl', 'blah');
b3381831
GS
130{
131
05fc92f1 132 local @bee = @bee;
b5adc3e5 133 is("@bee", "foo bar burbl blah"); # 43
b3381831 134 {
05fc92f1 135 local (undef,@bee) = @bee;
b5adc3e5 136 is("@bee", "bar burbl blah"); # 44
b3381831 137 {
05fc92f1 138 local @bee = ('XXX',@bee,'YYY');
b5adc3e5 139 is("@bee", "XXX bar burbl blah YYY"); # 45
b3381831 140 {
05fc92f1 141 local @bee = local(@bee) = qw(foo bar burbl blah);
b5adc3e5 142 is("@bee", "foo bar burbl blah"); # 46
b3381831 143 {
05fc92f1 144 local (@bim) = local(@bee) = qw(foo bar);
b5adc3e5
DIM
145 is("@bee", "foo bar"); # 47
146 is("@bim", "foo bar"); # 48
b3381831 147 }
b5adc3e5 148 is("@bee", "foo bar burbl blah"); # 49
b3381831 149 }
b5adc3e5 150 is("@bee", "XXX bar burbl blah YYY"); # 50
b3381831 151 }
b5adc3e5 152 is("@bee", "bar burbl blah"); # 51
b3381831 153 }
b5adc3e5 154 is("@bee", "foo bar burbl blah"); # 52
b3381831
GS
155}
156
157# try the same with my
158{
05fc92f1 159 my @bee = @bee;
b5adc3e5 160 is("@bee", "foo bar burbl blah"); # 53
b3381831 161 {
05fc92f1 162 my (undef,@bee) = @bee;
b5adc3e5 163 is("@bee", "bar burbl blah"); # 54
b3381831 164 {
05fc92f1 165 my @bee = ('XXX',@bee,'YYY');
b5adc3e5 166 is("@bee", "XXX bar burbl blah YYY"); # 55
b3381831 167 {
05fc92f1 168 my @bee = my @bee = qw(foo bar burbl blah);
b5adc3e5 169 is("@bee", "foo bar burbl blah"); # 56
b3381831 170 {
05fc92f1 171 my (@bim) = my(@bee) = qw(foo bar);
b5adc3e5
DIM
172 is("@bee", "foo bar"); # 57
173 is("@bim", "foo bar"); # 58
b3381831 174 }
b5adc3e5 175 is("@bee", "foo bar burbl blah"); # 59
b3381831 176 }
b5adc3e5 177 is("@bee", "XXX bar burbl blah YYY"); # 60
b3381831 178 }
b5adc3e5 179 is("@bee", "bar burbl blah"); # 61
b3381831 180 }
b5adc3e5 181 is("@bee", "foo bar burbl blah"); # 62
b3381831
GS
182}
183
f17e6c41
RGS
184# try the same with our (except that previous values aren't restored)
185{
186 our @bee = @bee;
187 is("@bee", "foo bar burbl blah");
188 {
189 our (undef,@bee) = @bee;
190 is("@bee", "bar burbl blah");
191 {
192 our @bee = ('XXX',@bee,'YYY');
193 is("@bee", "XXX bar burbl blah YYY");
194 {
195 our @bee = our @bee = qw(foo bar burbl blah);
196 is("@bee", "foo bar burbl blah");
197 {
198 our (@bim) = our(@bee) = qw(foo bar);
199 is("@bee", "foo bar");
200 is("@bim", "foo bar");
201 }
202 }
203 }
204 }
205}
206
352edd90 207# make sure reification behaves
0dd3f902
NC
208my $t = curr_test();
209sub reify { $_[1] = $t++; print "@_\n"; }
352edd90
GS
210reify('ok');
211reify('ok');
9d001be8 212
0dd3f902 213curr_test($t);
7517970f 214
0dd3f902
NC
215# qw() is no longer a runtime split, it's compiletime.
216is (qw(foo bar snorfle)[2], 'snorfle');
7517970f 217
0dd3f902 218@ary = (12,23,34,45,56);
7517970f 219
0dd3f902
NC
220is(shift(@ary), 12);
221is(pop(@ary), 56);
222is(push(@ary,56), 4);
223is(unshift(@ary,12), 5);
4c8f17b9
BH
224
225sub foo { "a" }
226@foo=(foo())[0,0];
0dd3f902 227is ($foo[1], "a");
b0840a2a 228
6b42d12b
DM
229# bugid #15439 - clearing an array calls destructors which may try
230# to modify the array - caused 'Attempt to free unreferenced scalar'
231
232my $got = runperl (
233 prog => q{
234 sub X::DESTROY { @a = () }
3d7a9343 235 @a = (bless {}, q{X});
6b42d12b
DM
236 @a = ();
237 },
238 stderr => 1
239 );
240
241$got =~ s/\n/ /g;
0dd3f902 242is ($got, '');
2b573ace
JH
243
244# Test negative and funky indices.
245
0dd3f902 246
2b573ace
JH
247{
248 my @a = 0..4;
0dd3f902
NC
249 is($a[-1], 4);
250 is($a[-2], 3);
251 is($a[-5], 0);
252 ok(!defined $a[-6]);
253
254 is($a[2.1] , 2);
255 is($a[2.9] , 2);
256 is($a[undef], 0);
257 is($a["3rd"], 3);
2b573ace
JH
258}
259
2b573ace
JH
260
261{
262 my @a;
263 eval '$a[-1] = 0';
0dd3f902 264 like($@, qr/Modification of non-creatable array value attempted, subscript -1/, "\$a[-1] = 0");
2b573ace 265}
0dd3f902 266
1b20cd17
NC
267sub test_arylen {
268 my $ref = shift;
83bf042f 269 local $^W = 1;
1b20cd17 270 is ($$ref, undef, "\$# on freed array is undef");
83bf042f
NC
271 my @warn;
272 local $SIG{__WARN__} = sub {push @warn, "@_"};
1b20cd17 273 $$ref = 1000;
83bf042f
NC
274 is (scalar @warn, 1);
275 like ($warn[0], qr/^Attempt to set length of freed array/);
276}
1b20cd17
NC
277
278{
279 my $a = \$#{[]};
280 # Need a new statement to make it go out of scope
281 test_arylen ($a);
282 test_arylen (do {my @a; \$#a});
283}
404a4710
NC
284
285{
286 use vars '@array';
287
288 my $outer = \$#array;
289 is ($$outer, -1);
290 is (scalar @array, 0);
291
292 $$outer = 3;
293 is ($$outer, 3);
294 is (scalar @array, 4);
295
296 my $ref = \@array;
297
404a4710
NC
298 my $inner;
299 {
300 local @array;
301 $inner = \$#array;
302
303 is ($$inner, -1);
304 is (scalar @array, 0);
305 $$outer = 6;
306
307 is (scalar @$ref, 7);
308
309 is ($$inner, -1);
310 is (scalar @array, 0);
311
312 $$inner = 42;
313 }
314
315 is (scalar @array, 7);
316 is ($$outer, 6);
317
2fc04a10 318 is ($$inner, undef, "orphaned $#foo is always undef");
404a4710
NC
319
320 is (scalar @array, 7);
321 is ($$outer, 6);
322
323 $$inner = 1;
324
325 is (scalar @array, 7);
326 is ($$outer, 6);
327
328 $$inner = 503; # Bang!
329
330 is (scalar @array, 7);
331 is ($$outer, 6);
332}
333
334{
335 # Bug #36211
336 use vars '@array';
337 for (1,2) {
338 {
339 local @a;
340 is ($#a, -1);
341 @a=(1..4)
342 }
343 }
344}
345
e4c5ccf3
RH
346{
347 # Bug #37350
348 my @array = (1..4);
349 $#{@array} = 7;
350 is ($#{4}, 7);
351
352 my $x;
353 $#{$x} = 3;
354 is(scalar @$x, 4);
355
356 push @{@array}, 23;
357 is ($4[8], 23);
358}
359{
360 # Bug #37350 -- once more with a global
361 use vars '@array';
362 @array = (1..4);
363 $#{@array} = 7;
364 is ($#{4}, 7);
365
366 my $x;
367 $#{$x} = 3;
368 is(scalar @$x, 4);
369
370 push @{@array}, 23;
371 is ($4[8], 23);
372}
373
f17e6c41
RGS
374# more tests for AASSIGN_COMMON
375
376{
377 our($x,$y,$z) = (1..3);
378 our($y,$z) = ($x,$y);
379 is("$x $y $z", "1 1 2");
380}
381{
382 our($x,$y,$z) = (1..3);
383 (our $y, our $z) = ($x,$y);
384 is("$x $y $z", "1 1 2");
385}
8d38d4f3 386{
3023b5f3 387 # AASSIGN_COMMON detection with logical operators
8d38d4f3
GG
388 my $true = 1;
389 our($x,$y,$z) = (1..3);
390 (our $y, our $z) = $true && ($x,$y);
391 is("$x $y $z", "1 1 2");
392}
f17e6c41 393
0f907b96
FC
394# [perl #70171]
395{
396 my $x = get_x(); my %x = %$x; sub get_x { %x=(1..4); return \%x };
397 is(
398 join(" ", map +($_,$x{$_}), sort keys %x), "1 2 3 4",
399 'bug 70171 (self-assignment via my %x = %$x)'
400 );
401 my $y = get_y(); my @y = @$y; sub get_y { @y=(1..4); return \@y };
402 is(
403 "@y", "1 2 3 4",
404 'bug 70171 (self-assignment via my @x = @$x)'
405 );
406}
407
ade1ceae
DM
408# [perl #70171], [perl #82110]
409{
410 my ($i, $ra, $rh);
411 again:
412 my @a = @$ra; # common assignment on 2nd attempt
413 my %h = %$rh; # common assignment on 2nd attempt
414 @a = qw(1 2 3 4);
415 %h = qw(a 1 b 2 c 3 d 4);
416 $ra = \@a;
417 $rh = \%h;
418 goto again unless $i++;
419
420 is("@a", "1 2 3 4",
421 'bug 70171 (self-assignment via my @x = @$x) - goto variant'
422 );
423 is(
424 join(" ", map +($_,$h{$_}), sort keys %h), "a 1 b 2 c 3 d 4",
425 'bug 70171 (self-assignment via my %x = %$x) - goto variant'
426 );
427}
428
429
8f878375
FC
430*trit = *scile; $trit[0];
431ok(1, 'aelem_fast on a nonexistent array does not crash');
f17e6c41 432
9f71cfe6
FC
433# [perl #107440]
434sub A::DESTROY { $::ra = 0 }
435$::ra = [ bless [], 'A' ];
436undef @$::ra;
437pass 'no crash when freeing array that is being undeffed';
438$::ra = [ bless [], 'A' ];
439@$::ra = ('a'..'z');
440pass 'no crash when freeing array that is being cleared';
441
70ce9249
FC
442# [perl #85670] Copying magic to elements
443SKIP: {
444 skip "no Scalar::Util::weaken on miniperl", 1, if is_miniperl;
445 require Scalar::Util;
446 package glelp {
447 Scalar::Util::weaken ($a = \@ISA);
448 @ISA = qw(Foo);
449 Scalar::Util::weaken ($a = \$ISA[0]);
450 ::is @ISA, 1, 'backref magic is not copied to elements';
451 }
452}
453package peen {
454 $#ISA = -1;
455 @ISA = qw(Foo);
456 $ISA[0] = qw(Sphare);
457
458 sub Sphare::pling { 'pling' }
459
460 ::is eval { pling peen }, 'pling',
461 'arylen_p magic does not stop isa magic from being copied';
462}
463
97568419
FC
464# Test that &PL_sv_undef is not special in arrays
465sub {
466 ok exists $_[0],
467 'exists returns true for &PL_sv_undef elem [perl #7508]';
468 is \$_[0], \undef, 'undef preserves identity in array [perl #109726]';
469}->(undef);
428ccf1e
FC
470# and that padav also knows how to handle the resulting NULLs
471@_ = sub { my @a; $a[1]=1; @a }->();
472is join (" ", map $_//"undef", @_), "undef 1",
473 'returning my @a with nonexistent elements';
97568419 474
bbfdc870
FC
475# [perl #118691]
476@plink=@plunk=();
477$plink[3] = 1;
478sub {
479 $_[0] = 2;
480 is $plink[0], 2, '@_ alias to nonexistent elem within array';
481 $_[1] = 3;
482 is $plink[1], 3, '@_ alias to nonexistent neg index within array';
483 is $_[2], undef, 'reading alias to negative index past beginning';
484 eval { $_[2] = 42 };
485 like $@, qr/Modification of non-creatable array value attempted, (?x:
486 )subscript -5/,
487 'error when setting alias to negative index past beginning';
488 is $_[3], undef, 'reading alias to -1 elem of empty array';
489 eval { $_[3] = 42 };
490 like $@, qr/Modification of non-creatable array value attempted, (?x:
491 )subscript -1/,
492 'error when setting alias to -1 elem of empty array';
493}->($plink[0], $plink[-2], $plink[-5], $plunk[-1]);
494
d4a823b3
FC
495$_ = \$#{[]};
496$$_ = \1;
497"$$_";
498pass "no assertion failure after assigning ref to arylen when ary is gone";
70ce9249 499
b024352e
DM
500
501{
502 # Test aelemfast for both +ve and -ve indices, both lex and package vars.
503 # Make especially careful that we don't have any edge cases around
504 # fitting an I8 into a U8.
505 my @a = (0..299);
506 is($a[-256], 300-256, 'lex -256');
507 is($a[-255], 300-255, 'lex -255');
508 is($a[-254], 300-254, 'lex -254');
509 is($a[-129], 300-129, 'lex -129');
510 is($a[-128], 300-128, 'lex -128');
511 is($a[-127], 300-127, 'lex -127');
512 is($a[-126], 300-126, 'lex -126');
513 is($a[ -1], 300- 1, 'lex -1');
514 is($a[ 0], 0, 'lex 0');
515 is($a[ 1], 1, 'lex 1');
516 is($a[ 126], 126, 'lex 126');
517 is($a[ 127], 127, 'lex 127');
518 is($a[ 128], 128, 'lex 128');
519 is($a[ 129], 129, 'lex 129');
520 is($a[ 254], 254, 'lex 254');
521 is($a[ 255], 255, 'lex 255');
522 is($a[ 256], 256, 'lex 256');
523 @aelem =(0..299);
524 is($aelem[-256], 300-256, 'pkg -256');
525 is($aelem[-255], 300-255, 'pkg -255');
526 is($aelem[-254], 300-254, 'pkg -254');
527 is($aelem[-129], 300-129, 'pkg -129');
528 is($aelem[-128], 300-128, 'pkg -128');
529 is($aelem[-127], 300-127, 'pkg -127');
530 is($aelem[-126], 300-126, 'pkg -126');
531 is($aelem[ -1], 300- 1, 'pkg -1');
532 is($aelem[ 0], 0, 'pkg 0');
533 is($aelem[ 1], 1, 'pkg 1');
534 is($aelem[ 126], 126, 'pkg 126');
535 is($aelem[ 127], 127, 'pkg 127');
536 is($aelem[ 128], 128, 'pkg 128');
537 is($aelem[ 129], 129, 'pkg 129');
538 is($aelem[ 254], 254, 'pkg 254');
539 is($aelem[ 255], 255, 'pkg 255');
540 is($aelem[ 256], 256, 'pkg 256');
541}
542
689d8423
FC
543# Test aelemfast in list assignment
544@ary = ('a','b');
545($ary[0],$ary[1]) = ($ary[1],$ary[0]);
546is "@ary", 'b a',
547 'aelemfast with the same array on both sides of list assignment';
548
569ddb4a
FC
549for(scalar $#foo) { $_ = 3 }
550is $#foo, 3, 'assigning to arylen aliased in foreach(scalar $#arylen)';
551
a5f48505
DM
552{
553 my @a = qw(a b c);
554 @a = @a;
555 is "@a", 'a b c', 'assigning to itself';
556}
557
94f9945d
FC
558sub { undef *_; shift }->(); # This would crash; no ok() necessary.
559sub { undef *_; pop }->();
560
92b69f65
FC
561# [perl #129164], [perl #129166], [perl #129167]
562# splice() with null array entries
563# These used to crash.
564$#a = -1; $#a++;
565() = 0-splice @a; # subtract
566$#a = -1; $#a++;
567() = -splice @a; # negate
568$#a = -1; $#a++;
569() = 0+splice @a; # add
570# And with array expansion, too
571$#a = -1; $#a++;
572() = 0-splice @a, 0, 1, 1, 1;
573$#a = -1; $#a++;
574() = -splice @a, 0, 1, 1, 1;
575$#a = -1; $#a++;
576() = 0+splice @a, 0, 1, 1, 1;
577
404a4710 578"We're included by lib/Tie/Array/std.t so we need to return something true";