This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[MERGE] optmise pp_entersub code
[perl5.git] / t / op / array.t
CommitLineData
a687059c
LW
1#!./perl
2
6b42d12b
DM
3BEGIN {
4 chdir 't' if -d 't';
404a4710 5 @INC = ('.', '../lib');
9f71cfe6 6 require 'test.pl';
6b42d12b
DM
7}
8
428ccf1e 9plan (137);
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
c6aa4a32 103@foo = ( 'foo', 'bar', 'burbl');
136c2a5e
NC
104{
105 no warnings 'deprecated';
106 push(foo, 'blah');
107}
0dd3f902 108is($#foo, 3);
b3381831
GS
109
110# various AASSIGN_COMMON checks (see newASSIGNOP() in op.c)
111
0dd3f902 112#curr_test(38);
b3381831
GS
113
114@foo = @foo;
0dd3f902 115is("@foo", "foo bar burbl blah"); # 38
b3381831
GS
116
117(undef,@foo) = @foo;
0dd3f902 118is("@foo", "bar burbl blah"); # 39
b3381831
GS
119
120@foo = ('XXX',@foo, 'YYY');
0dd3f902 121is("@foo", "XXX bar burbl blah YYY"); # 40
b3381831 122
3201ebbd 123@foo = @foo = qw(foo b\a\r bu\\rbl blah);
0dd3f902 124is("@foo", 'foo b\a\r bu\\rbl blah'); # 41
b3381831
GS
125
126@bar = @foo = qw(foo bar); # 42
0dd3f902
NC
127is("@foo", "foo bar");
128is("@bar", "foo bar"); # 43
b3381831
GS
129
130# try the same with local
05fc92f1
GS
131# XXX tie-stdarray fails the tests involving local, so we use
132# different variable names to escape the 'tie'
133
134@bee = ( 'foo', 'bar', 'burbl', 'blah');
b3381831
GS
135{
136
05fc92f1 137 local @bee = @bee;
0dd3f902 138 is("@bee", "foo bar burbl blah"); # 44
b3381831 139 {
05fc92f1 140 local (undef,@bee) = @bee;
0dd3f902 141 is("@bee", "bar burbl blah"); # 45
b3381831 142 {
05fc92f1 143 local @bee = ('XXX',@bee,'YYY');
0dd3f902 144 is("@bee", "XXX bar burbl blah YYY"); # 46
b3381831 145 {
05fc92f1 146 local @bee = local(@bee) = qw(foo bar burbl blah);
0dd3f902 147 is("@bee", "foo bar burbl blah"); # 47
b3381831 148 {
05fc92f1 149 local (@bim) = local(@bee) = qw(foo bar);
0dd3f902
NC
150 is("@bee", "foo bar"); # 48
151 is("@bim", "foo bar"); # 49
b3381831 152 }
0dd3f902 153 is("@bee", "foo bar burbl blah"); # 50
b3381831 154 }
0dd3f902 155 is("@bee", "XXX bar burbl blah YYY"); # 51
b3381831 156 }
0dd3f902 157 is("@bee", "bar burbl blah"); # 52
b3381831 158 }
0dd3f902 159 is("@bee", "foo bar burbl blah"); # 53
b3381831
GS
160}
161
162# try the same with my
163{
05fc92f1 164 my @bee = @bee;
0dd3f902 165 is("@bee", "foo bar burbl blah"); # 54
b3381831 166 {
05fc92f1 167 my (undef,@bee) = @bee;
0dd3f902 168 is("@bee", "bar burbl blah"); # 55
b3381831 169 {
05fc92f1 170 my @bee = ('XXX',@bee,'YYY');
0dd3f902 171 is("@bee", "XXX bar burbl blah YYY"); # 56
b3381831 172 {
05fc92f1 173 my @bee = my @bee = qw(foo bar burbl blah);
0dd3f902 174 is("@bee", "foo bar burbl blah"); # 57
b3381831 175 {
05fc92f1 176 my (@bim) = my(@bee) = qw(foo bar);
0dd3f902
NC
177 is("@bee", "foo bar"); # 58
178 is("@bim", "foo bar"); # 59
b3381831 179 }
0dd3f902 180 is("@bee", "foo bar burbl blah"); # 60
b3381831 181 }
0dd3f902 182 is("@bee", "XXX bar burbl blah YYY"); # 61
b3381831 183 }
0dd3f902 184 is("@bee", "bar burbl blah"); # 62
b3381831 185 }
0dd3f902 186 is("@bee", "foo bar burbl blah"); # 63
b3381831
GS
187}
188
f17e6c41
RGS
189# try the same with our (except that previous values aren't restored)
190{
191 our @bee = @bee;
192 is("@bee", "foo bar burbl blah");
193 {
194 our (undef,@bee) = @bee;
195 is("@bee", "bar burbl blah");
196 {
197 our @bee = ('XXX',@bee,'YYY');
198 is("@bee", "XXX bar burbl blah YYY");
199 {
200 our @bee = our @bee = qw(foo bar burbl blah);
201 is("@bee", "foo bar burbl blah");
202 {
203 our (@bim) = our(@bee) = qw(foo bar);
204 is("@bee", "foo bar");
205 is("@bim", "foo bar");
206 }
207 }
208 }
209 }
210}
211
352edd90 212# make sure reification behaves
0dd3f902
NC
213my $t = curr_test();
214sub reify { $_[1] = $t++; print "@_\n"; }
352edd90
GS
215reify('ok');
216reify('ok');
9d001be8 217
0dd3f902 218curr_test($t);
7517970f 219
0dd3f902
NC
220# qw() is no longer a runtime split, it's compiletime.
221is (qw(foo bar snorfle)[2], 'snorfle');
7517970f 222
0dd3f902 223@ary = (12,23,34,45,56);
7517970f 224
0dd3f902
NC
225is(shift(@ary), 12);
226is(pop(@ary), 56);
227is(push(@ary,56), 4);
228is(unshift(@ary,12), 5);
4c8f17b9
BH
229
230sub foo { "a" }
231@foo=(foo())[0,0];
0dd3f902 232is ($foo[1], "a");
b0840a2a 233
6b42d12b
DM
234# bugid #15439 - clearing an array calls destructors which may try
235# to modify the array - caused 'Attempt to free unreferenced scalar'
236
237my $got = runperl (
238 prog => q{
239 sub X::DESTROY { @a = () }
3d7a9343 240 @a = (bless {}, q{X});
6b42d12b
DM
241 @a = ();
242 },
243 stderr => 1
244 );
245
246$got =~ s/\n/ /g;
0dd3f902 247is ($got, '');
2b573ace
JH
248
249# Test negative and funky indices.
250
0dd3f902 251
2b573ace
JH
252{
253 my @a = 0..4;
0dd3f902
NC
254 is($a[-1], 4);
255 is($a[-2], 3);
256 is($a[-5], 0);
257 ok(!defined $a[-6]);
258
259 is($a[2.1] , 2);
260 is($a[2.9] , 2);
261 is($a[undef], 0);
262 is($a["3rd"], 3);
2b573ace
JH
263}
264
2b573ace
JH
265
266{
267 my @a;
268 eval '$a[-1] = 0';
0dd3f902 269 like($@, qr/Modification of non-creatable array value attempted, subscript -1/, "\$a[-1] = 0");
2b573ace 270}
0dd3f902 271
1b20cd17
NC
272sub test_arylen {
273 my $ref = shift;
83bf042f 274 local $^W = 1;
1b20cd17 275 is ($$ref, undef, "\$# on freed array is undef");
83bf042f
NC
276 my @warn;
277 local $SIG{__WARN__} = sub {push @warn, "@_"};
1b20cd17 278 $$ref = 1000;
83bf042f
NC
279 is (scalar @warn, 1);
280 like ($warn[0], qr/^Attempt to set length of freed array/);
281}
1b20cd17
NC
282
283{
284 my $a = \$#{[]};
285 # Need a new statement to make it go out of scope
286 test_arylen ($a);
287 test_arylen (do {my @a; \$#a});
288}
404a4710
NC
289
290{
291 use vars '@array';
292
293 my $outer = \$#array;
294 is ($$outer, -1);
295 is (scalar @array, 0);
296
297 $$outer = 3;
298 is ($$outer, 3);
299 is (scalar @array, 4);
300
301 my $ref = \@array;
302
404a4710
NC
303 my $inner;
304 {
305 local @array;
306 $inner = \$#array;
307
308 is ($$inner, -1);
309 is (scalar @array, 0);
310 $$outer = 6;
311
312 is (scalar @$ref, 7);
313
314 is ($$inner, -1);
315 is (scalar @array, 0);
316
317 $$inner = 42;
318 }
319
320 is (scalar @array, 7);
321 is ($$outer, 6);
322
2fc04a10 323 is ($$inner, undef, "orphaned $#foo is always undef");
404a4710
NC
324
325 is (scalar @array, 7);
326 is ($$outer, 6);
327
328 $$inner = 1;
329
330 is (scalar @array, 7);
331 is ($$outer, 6);
332
333 $$inner = 503; # Bang!
334
335 is (scalar @array, 7);
336 is ($$outer, 6);
337}
338
339{
340 # Bug #36211
341 use vars '@array';
342 for (1,2) {
343 {
344 local @a;
345 is ($#a, -1);
346 @a=(1..4)
347 }
348 }
349}
350
e4c5ccf3
RH
351{
352 # Bug #37350
353 my @array = (1..4);
354 $#{@array} = 7;
355 is ($#{4}, 7);
356
357 my $x;
358 $#{$x} = 3;
359 is(scalar @$x, 4);
360
361 push @{@array}, 23;
362 is ($4[8], 23);
363}
364{
365 # Bug #37350 -- once more with a global
366 use vars '@array';
367 @array = (1..4);
368 $#{@array} = 7;
369 is ($#{4}, 7);
370
371 my $x;
372 $#{$x} = 3;
373 is(scalar @$x, 4);
374
375 push @{@array}, 23;
376 is ($4[8], 23);
377}
378
f17e6c41
RGS
379# more tests for AASSIGN_COMMON
380
381{
382 our($x,$y,$z) = (1..3);
383 our($y,$z) = ($x,$y);
384 is("$x $y $z", "1 1 2");
385}
386{
387 our($x,$y,$z) = (1..3);
388 (our $y, our $z) = ($x,$y);
389 is("$x $y $z", "1 1 2");
390}
8d38d4f3 391{
3023b5f3 392 # AASSIGN_COMMON detection with logical operators
8d38d4f3
GG
393 my $true = 1;
394 our($x,$y,$z) = (1..3);
395 (our $y, our $z) = $true && ($x,$y);
396 is("$x $y $z", "1 1 2");
397}
f17e6c41 398
0f907b96
FC
399# [perl #70171]
400{
401 my $x = get_x(); my %x = %$x; sub get_x { %x=(1..4); return \%x };
402 is(
403 join(" ", map +($_,$x{$_}), sort keys %x), "1 2 3 4",
404 'bug 70171 (self-assignment via my %x = %$x)'
405 );
406 my $y = get_y(); my @y = @$y; sub get_y { @y=(1..4); return \@y };
407 is(
408 "@y", "1 2 3 4",
409 'bug 70171 (self-assignment via my @x = @$x)'
410 );
411}
412
ade1ceae
DM
413# [perl #70171], [perl #82110]
414{
415 my ($i, $ra, $rh);
416 again:
417 my @a = @$ra; # common assignment on 2nd attempt
418 my %h = %$rh; # common assignment on 2nd attempt
419 @a = qw(1 2 3 4);
420 %h = qw(a 1 b 2 c 3 d 4);
421 $ra = \@a;
422 $rh = \%h;
423 goto again unless $i++;
424
425 is("@a", "1 2 3 4",
426 'bug 70171 (self-assignment via my @x = @$x) - goto variant'
427 );
428 is(
429 join(" ", map +($_,$h{$_}), sort keys %h), "a 1 b 2 c 3 d 4",
430 'bug 70171 (self-assignment via my %x = %$x) - goto variant'
431 );
432}
433
434
8f878375
FC
435*trit = *scile; $trit[0];
436ok(1, 'aelem_fast on a nonexistent array does not crash');
f17e6c41 437
9f71cfe6
FC
438# [perl #107440]
439sub A::DESTROY { $::ra = 0 }
440$::ra = [ bless [], 'A' ];
441undef @$::ra;
442pass 'no crash when freeing array that is being undeffed';
443$::ra = [ bless [], 'A' ];
444@$::ra = ('a'..'z');
445pass 'no crash when freeing array that is being cleared';
446
70ce9249
FC
447# [perl #85670] Copying magic to elements
448SKIP: {
449 skip "no Scalar::Util::weaken on miniperl", 1, if is_miniperl;
450 require Scalar::Util;
451 package glelp {
452 Scalar::Util::weaken ($a = \@ISA);
453 @ISA = qw(Foo);
454 Scalar::Util::weaken ($a = \$ISA[0]);
455 ::is @ISA, 1, 'backref magic is not copied to elements';
456 }
457}
458package peen {
459 $#ISA = -1;
460 @ISA = qw(Foo);
461 $ISA[0] = qw(Sphare);
462
463 sub Sphare::pling { 'pling' }
464
465 ::is eval { pling peen }, 'pling',
466 'arylen_p magic does not stop isa magic from being copied';
467}
468
97568419
FC
469# Test that &PL_sv_undef is not special in arrays
470sub {
471 ok exists $_[0],
472 'exists returns true for &PL_sv_undef elem [perl #7508]';
473 is \$_[0], \undef, 'undef preserves identity in array [perl #109726]';
474}->(undef);
428ccf1e
FC
475# and that padav also knows how to handle the resulting NULLs
476@_ = sub { my @a; $a[1]=1; @a }->();
477is join (" ", map $_//"undef", @_), "undef 1",
478 'returning my @a with nonexistent elements';
97568419 479
bbfdc870
FC
480# [perl #118691]
481@plink=@plunk=();
482$plink[3] = 1;
483sub {
484 $_[0] = 2;
485 is $plink[0], 2, '@_ alias to nonexistent elem within array';
486 $_[1] = 3;
487 is $plink[1], 3, '@_ alias to nonexistent neg index within array';
488 is $_[2], undef, 'reading alias to negative index past beginning';
489 eval { $_[2] = 42 };
490 like $@, qr/Modification of non-creatable array value attempted, (?x:
491 )subscript -5/,
492 'error when setting alias to negative index past beginning';
493 is $_[3], undef, 'reading alias to -1 elem of empty array';
494 eval { $_[3] = 42 };
495 like $@, qr/Modification of non-creatable array value attempted, (?x:
496 )subscript -1/,
497 'error when setting alias to -1 elem of empty array';
498}->($plink[0], $plink[-2], $plink[-5], $plunk[-1]);
499
d4a823b3
FC
500$_ = \$#{[]};
501$$_ = \1;
502"$$_";
503pass "no assertion failure after assigning ref to arylen when ary is gone";
70ce9249 504
404a4710 505"We're included by lib/Tie/Array/std.t so we need to return something true";