Epigraph for 5.29.8
[perl.git] / t / op / array.t
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     require './test.pl';
6     set_up_inc('.', '../lib');
7 }
8
9 plan (194);
10
11 #
12 # @foo, @bar, and @ary are also used from tie-stdarray after tie-ing them
13 #
14
15 @ary = (1,2,3,4,5);
16 is(join('',@ary), '12345');
17
18 $tmp = $ary[$#ary]; --$#ary;
19 is($tmp, 5);
20 is($#ary, 3);
21 is(join('',@ary), '1234');
22
23 @foo = ();
24 $r = join(',', $#foo, @foo);
25 is($r, "-1");
26 $foo[0] = '0';
27 $r = join(',', $#foo, @foo);
28 is($r, "0,0");
29 $foo[2] = '2';
30 $r = join(',', $#foo, @foo);
31 is($r, "2,0,,2");
32 @bar = ();
33 $bar[0] = '0';
34 $bar[1] = '1';
35 $r = join(',', $#bar, @bar);
36 is($r, "1,0,1");
37 @bar = ();
38 $r = join(',', $#bar, @bar);
39 is($r, "-1");
40 $bar[0] = '0';
41 $r = join(',', $#bar, @bar);
42 is($r, "0,0");
43 $bar[2] = '2';
44 $r = join(',', $#bar, @bar);
45 is($r, "2,0,,2");
46 reset 'b' if $^O ne 'VMS';
47 @bar = ();
48 $bar[0] = '0';
49 $r = join(',', $#bar, @bar);
50 is($r, "0,0");
51 $bar[2] = '2';
52 $r = join(',', $#bar, @bar);
53 is($r, "2,0,,2");
54
55 $foo = 'now is the time';
56 ok(scalar (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/)));
57 is($F1, 'now');
58 is($F2, 'is');
59 is($Etc, 'the time');
60
61 $foo = 'lskjdf';
62 ok(!($cnt = (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/))))
63    or diag("$cnt $F1:$F2:$Etc");
64
65 %foo = ('blurfl','dyick','foo','bar','etc.','etc.');
66 %bar = %foo;
67 is($bar{'foo'}, 'bar');
68 %bar = ();
69 is($bar{'foo'}, undef);
70 (%bar,$a,$b) = (%foo,'how','now');
71 is($bar{'foo'}, 'bar');
72 is($bar{'how'}, 'now');
73 @bar{keys %foo} = values %foo;
74 is($bar{'foo'}, 'bar');
75 is($bar{'how'}, 'now');
76
77 @foo = grep(/e/,split(' ','now is the time for all good men to come to'));
78 is(join(' ',@foo), 'the time men come');
79
80 @foo = grep(!/e/,split(' ','now is the time for all good men to come to'));
81 is(join(' ',@foo), 'now is for all good to to');
82
83 $foo = join('',('a','b','c','d','e','f')[0..5]);
84 is($foo, 'abcdef');
85
86 $foo = join('',('a','b','c','d','e','f')[0..1]);
87 is($foo, 'ab');
88
89 $foo = join('',('a','b','c','d','e','f')[6]);
90 is($foo, '');
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]);
95 is($foo, 'acebdf');
96
97 $foo = ('a','b','c','d','e','f')[0,2,4];
98 is($foo, 'e');
99
100 $foo = ('a','b','c','d','e','f')[1];
101 is($foo, 'b');
102
103 @foo = ( 'foo', 'bar', 'burbl', 'blah');
104
105 # various AASSIGN_COMMON checks (see newASSIGNOP() in op.c)
106
107 #curr_test(37);
108
109 @foo = @foo;
110 is("@foo", "foo bar burbl blah");                               # 37
111
112 (undef,@foo) = @foo;
113 is("@foo", "bar burbl blah");                                   # 38
114
115 @foo = ('XXX',@foo, 'YYY');
116 is("@foo", "XXX bar burbl blah YYY");                           # 39
117
118 @foo = @foo = qw(foo b\a\r bu\\rbl blah);
119 is("@foo", 'foo b\a\r bu\\rbl blah');                           # 40
120
121 @bar = @foo = qw(foo bar);                                      # 41
122 is("@foo", "foo bar");
123 is("@bar", "foo bar");                                          # 42
124
125 # try the same with local
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');
130 {
131
132     local @bee = @bee;
133     is("@bee", "foo bar burbl blah");                           # 43
134     {
135         local (undef,@bee) = @bee;
136         is("@bee", "bar burbl blah");                           # 44
137         {
138             local @bee = ('XXX',@bee,'YYY');
139             is("@bee", "XXX bar burbl blah YYY");               # 45
140             {
141                 local @bee = local(@bee) = qw(foo bar burbl blah);
142                 is("@bee", "foo bar burbl blah");               # 46
143                 {
144                     local (@bim) = local(@bee) = qw(foo bar);
145                     is("@bee", "foo bar");                      # 47
146                     is("@bim", "foo bar");                      # 48
147                 }
148                 is("@bee", "foo bar burbl blah");               # 49
149             }
150             is("@bee", "XXX bar burbl blah YYY");               # 50
151         }
152         is("@bee", "bar burbl blah");                           # 51
153     }
154     is("@bee", "foo bar burbl blah");                           # 52
155 }
156
157 # try the same with my
158 {
159     my @bee = @bee;
160     is("@bee", "foo bar burbl blah");                           # 53
161     {
162         my (undef,@bee) = @bee;
163         is("@bee", "bar burbl blah");                           # 54
164         {
165             my @bee = ('XXX',@bee,'YYY');
166             is("@bee", "XXX bar burbl blah YYY");               # 55
167             {
168                 my @bee = my @bee = qw(foo bar burbl blah);
169                 is("@bee", "foo bar burbl blah");               # 56
170                 {
171                     my (@bim) = my(@bee) = qw(foo bar);
172                     is("@bee", "foo bar");                      # 57
173                     is("@bim", "foo bar");                      # 58
174                 }
175                 is("@bee", "foo bar burbl blah");               # 59
176             }
177             is("@bee", "XXX bar burbl blah YYY");               # 60
178         }
179         is("@bee", "bar burbl blah");                           # 61
180     }
181     is("@bee", "foo bar burbl blah");                           # 62
182 }
183
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
207 # make sure reification behaves
208 my $t = curr_test();
209 sub reify { $_[1] = $t++; print "@_\n"; }
210 reify('ok');
211 reify('ok');
212
213 curr_test($t);
214
215 # qw() is no longer a runtime split, it's compiletime.
216 is (qw(foo bar snorfle)[2], 'snorfle');
217
218 @ary = (12,23,34,45,56);
219
220 is(shift(@ary), 12);
221 is(pop(@ary), 56);
222 is(push(@ary,56), 4);
223 is(unshift(@ary,12), 5);
224
225 sub foo { "a" }
226 @foo=(foo())[0,0];
227 is ($foo[1], "a");
228
229 # bugid #15439 - clearing an array calls destructors which may try
230 # to modify the array - caused 'Attempt to free unreferenced scalar'
231
232 my $got = runperl (
233         prog => q{
234                     sub X::DESTROY { @a = () }
235                     @a = (bless {}, q{X});
236                     @a = ();
237                 },
238         stderr => 1
239     );
240
241 $got =~ s/\n/ /g;
242 is ($got, '');
243
244 # Test negative and funky indices.
245
246
247 {
248     my @a = 0..4;
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);
258 }
259
260
261 {
262     my @a;
263     eval '$a[-1] = 0';
264     like($@, qr/Modification of non-creatable array value attempted, subscript -1/, "\$a[-1] = 0");
265 }
266
267 sub test_arylen {
268     my $ref = shift;
269     local $^W = 1;
270     is ($$ref, undef, "\$# on freed array is undef");
271     my @warn;
272     local $SIG{__WARN__} = sub {push @warn, "@_"};
273     $$ref = 1000;
274     is (scalar @warn, 1);
275     like ($warn[0], qr/^Attempt to set length of freed array/);
276 }
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 }
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
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
318     is ($$inner, undef, "orphaned $#foo is always undef");
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
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
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 }
386 {
387     # AASSIGN_COMMON detection with logical operators
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 }
393
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
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
430 *trit = *scile;  $trit[0];
431 ok(1, 'aelem_fast on a nonexistent array does not crash');
432
433 # [perl #107440]
434 sub A::DESTROY { $::ra = 0 }
435 $::ra = [ bless [], 'A' ];
436 undef @$::ra;
437 pass 'no crash when freeing array that is being undeffed';
438 $::ra = [ bless [], 'A' ];
439 @$::ra = ('a'..'z');
440 pass 'no crash when freeing array that is being cleared';
441
442 # [perl #85670] Copying magic to elements
443 SKIP: {
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 }
453 package 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
464 # Test that &PL_sv_undef is not special in arrays
465 sub {
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);
470 # and that padav also knows how to handle the resulting NULLs
471 @_ = sub { my @a; $a[1]=1; @a }->();
472 is join (" ", map $_//"undef", @_), "undef 1",
473   'returning my @a with nonexistent elements'; 
474
475 # [perl #118691]
476 @plink=@plunk=();
477 $plink[3] = 1;
478 sub {
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
495 $_ = \$#{[]};
496 $$_ = \1;
497 "$$_";
498 pass "no assertion failure after assigning ref to arylen when ary is gone";
499
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
543 # Test aelemfast in list assignment
544 @ary = ('a','b');
545 ($ary[0],$ary[1]) = ($ary[1],$ary[0]);
546 is "@ary", 'b a',
547    'aelemfast with the same array on both sides of list assignment';
548
549 for(scalar $#foo) { $_ = 3 }
550 is $#foo, 3, 'assigning to arylen aliased in foreach(scalar $#arylen)';
551
552 {
553     my @a = qw(a b c);
554     @a = @a;
555     is "@a", 'a b c', 'assigning to itself';
556 }
557
558 sub { undef *_; shift }->(); # This would crash; no ok() necessary.
559 sub { undef *_; pop   }->();
560
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
578 # [perl #8910] lazy creation of array elements used to leak out
579 {
580     sub t8910 { $_[1] = 5; $_[2] = 7; }
581     my @p;
582     $p[0] = 1;
583     $p[2] = 2;
584     t8910(@p);
585     is "@p", "1 5 7", "lazy element creation with sub call";
586     my @q;
587     @q[0] = 1;
588     @q[2] = 2;
589     my @qr = \(@q);
590     is $qr[$_], \$q[$_], "lazy element creation with refgen" foreach 0..2;
591     isnt $qr[1], \undef, "lazy element creation with refgen";
592     my @r;
593     $r[1] = 1;
594     foreach my $re ((), @r) { $re = 5; }
595     is join("", @r), "55", "lazy element creation with foreach";
596 }
597
598 { # Some things broken by the initial fix for #8910
599     (\my @a)->$#*++;
600     my @b = @a;
601     ok !exists $a[0], 'copying an array via = does not vivify elements';
602     delete $a[0];
603     @a[1..5] = 1..5;
604     $#a++;
605     my $count;
606     my @existing_elements = map { exists $a[$count++] ? $_ : () } @a;
607     is join(",", @existing_elements), "1,2,3,4,5",
608        'map {} @a does not vivify elements';
609     $#a = -1;
610     {local $a[3] = 12; my @foo=@a};
611     is @a, 0,'unwinding localization of elem past end of array shrinks it';
612
613     # Again, but with a package array
614     package tmp; (\our @a)->$#*++; package main;
615     my @b = @a;
616     ok !exists $a[0], 'copying an array via = does not vivify elements';
617     delete $a[0];
618     @a[1..5] = 1..5;
619     $#a++;
620     my $count;
621     my @existing_elements = map { exists $a[$count++] ? $_ : () } @a;
622     is join(",", @existing_elements), "1,2,3,4,5",
623        'map {} @a does not vivify elements';
624     $#a = -1;
625     {local $a[3] = 12; my @foo=@a};
626     is @a, 0,'unwinding localization of elem past end of array shrinks it';
627 }
628 {
629     # Again, but with a non-magical array ($#a makes it magical)
630     my @a = 1;
631     delete $a[0];
632     my @b = @a;
633     ok !exists $a[0], 'copying an array via = does not vivify elements';
634     delete $a[0];
635     @a[1..5] = 1..5;
636     my $count;
637     my @existing_elements = map { exists $a[$count++] ? $_ : () } @a;
638     is join(",", @existing_elements), "1,2,3,4,5",
639        'map {} @a does not vivify elements';
640     @a = ();
641     {local $a[3] = 12; my @foo=@a};
642     is @a, 0, 'unwinding localization of elem past end of array shrinks it'
643 }
644
645 # perl #132729, as it applies to flattening an array in lvalue context
646 {
647     my @a;
648     $a[1] = 1;
649     map { unshift @a, 7; $_ = 3; goto aftermap; } @a;
650    aftermap:
651     is "[@a]", "[7 3 1]",
652        'non-elems read from @a do not lose their position';
653     @a = ();
654     $#a++; # make it magical
655     $a[1] = 1;
656     map { unshift @a, 7; $_ = 3; goto aftermath; } @a;
657    aftermath:
658     is "[@a]", "[7 3 1]",
659        'non-elems read from magical @a do not lose their position';
660 }
661 # perl #132729, as it applies to ‘holes’ in an array passed to a sub
662 # individually
663 {
664     my @a;
665     $a[1] = 1;
666     sub { unshift @a, 7; $_[0] = 3; }->($a[0]);
667     is "[@a]", "[7 3 1]",
668        'holes passed to sub do not lose their position (multideref)';
669     @a = ();
670     $#a++; # make it magical
671     $a[1] = 1;
672     sub { unshift @a, 7; $_[0] = 3; }->($a[0]);
673     is "[@a]", "[7 3 1]",
674        'holes passed to sub do not lose their position (multideref, mg)';
675 }
676 {
677     # Again, with aelem, not multideref
678     my @a;
679     $a[1] = 1;
680     sub { unshift @a, 7; $_[0] = 3; }->($a[${\0}]);
681     is "[@a]", "[7 3 1]",
682        'holes passed to sub do not lose their position (aelem)';
683     @a = ();
684     $#a++; # make it magical
685     $a[1] = 1;
686     sub { unshift @a, 7; $_[0] = 3; }->($a[${\0}]);
687     is "[@a]", "[7 3 1]",
688        'holes passed to sub do not lose their position (aelem, mg)';
689 }
690
691 "We're included by lib/Tie/Array/std.t so we need to return something true";