This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
74868088e44471773d96f8af19ba71cd29b4efc7
[perl5.git] / t / op / array.t
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     @INC = ('.', '../lib');
6     require 'test.pl';
7 }
8
9 plan (171);
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');
104 {
105     no warnings 'deprecated';
106     push(foo, 'blah');
107 }
108 is($#foo, 3);
109
110 # various AASSIGN_COMMON checks (see newASSIGNOP() in op.c)
111
112 #curr_test(38);
113
114 @foo = @foo;
115 is("@foo", "foo bar burbl blah");                               # 38
116
117 (undef,@foo) = @foo;
118 is("@foo", "bar burbl blah");                                   # 39
119
120 @foo = ('XXX',@foo, 'YYY');
121 is("@foo", "XXX bar burbl blah YYY");                           # 40
122
123 @foo = @foo = qw(foo b\a\r bu\\rbl blah);
124 is("@foo", 'foo b\a\r bu\\rbl blah');                           # 41
125
126 @bar = @foo = qw(foo bar);                                      # 42
127 is("@foo", "foo bar");
128 is("@bar", "foo bar");                                          # 43
129
130 # try the same with local
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');
135 {
136
137     local @bee = @bee;
138     is("@bee", "foo bar burbl blah");                           # 44
139     {
140         local (undef,@bee) = @bee;
141         is("@bee", "bar burbl blah");                           # 45
142         {
143             local @bee = ('XXX',@bee,'YYY');
144             is("@bee", "XXX bar burbl blah YYY");               # 46
145             {
146                 local @bee = local(@bee) = qw(foo bar burbl blah);
147                 is("@bee", "foo bar burbl blah");               # 47
148                 {
149                     local (@bim) = local(@bee) = qw(foo bar);
150                     is("@bee", "foo bar");                      # 48
151                     is("@bim", "foo bar");                      # 49
152                 }
153                 is("@bee", "foo bar burbl blah");               # 50
154             }
155             is("@bee", "XXX bar burbl blah YYY");               # 51
156         }
157         is("@bee", "bar burbl blah");                           # 52
158     }
159     is("@bee", "foo bar burbl blah");                           # 53
160 }
161
162 # try the same with my
163 {
164     my @bee = @bee;
165     is("@bee", "foo bar burbl blah");                           # 54
166     {
167         my (undef,@bee) = @bee;
168         is("@bee", "bar burbl blah");                           # 55
169         {
170             my @bee = ('XXX',@bee,'YYY');
171             is("@bee", "XXX bar burbl blah YYY");               # 56
172             {
173                 my @bee = my @bee = qw(foo bar burbl blah);
174                 is("@bee", "foo bar burbl blah");               # 57
175                 {
176                     my (@bim) = my(@bee) = qw(foo bar);
177                     is("@bee", "foo bar");                      # 58
178                     is("@bim", "foo bar");                      # 59
179                 }
180                 is("@bee", "foo bar burbl blah");               # 60
181             }
182             is("@bee", "XXX bar burbl blah YYY");               # 61
183         }
184         is("@bee", "bar burbl blah");                           # 62
185     }
186     is("@bee", "foo bar burbl blah");                           # 63
187 }
188
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
212 # make sure reification behaves
213 my $t = curr_test();
214 sub reify { $_[1] = $t++; print "@_\n"; }
215 reify('ok');
216 reify('ok');
217
218 curr_test($t);
219
220 # qw() is no longer a runtime split, it's compiletime.
221 is (qw(foo bar snorfle)[2], 'snorfle');
222
223 @ary = (12,23,34,45,56);
224
225 is(shift(@ary), 12);
226 is(pop(@ary), 56);
227 is(push(@ary,56), 4);
228 is(unshift(@ary,12), 5);
229
230 sub foo { "a" }
231 @foo=(foo())[0,0];
232 is ($foo[1], "a");
233
234 # bugid #15439 - clearing an array calls destructors which may try
235 # to modify the array - caused 'Attempt to free unreferenced scalar'
236
237 my $got = runperl (
238         prog => q{
239                     sub X::DESTROY { @a = () }
240                     @a = (bless {}, q{X});
241                     @a = ();
242                 },
243         stderr => 1
244     );
245
246 $got =~ s/\n/ /g;
247 is ($got, '');
248
249 # Test negative and funky indices.
250
251
252 {
253     my @a = 0..4;
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);
263 }
264
265
266 {
267     my @a;
268     eval '$a[-1] = 0';
269     like($@, qr/Modification of non-creatable array value attempted, subscript -1/, "\$a[-1] = 0");
270 }
271
272 sub test_arylen {
273     my $ref = shift;
274     local $^W = 1;
275     is ($$ref, undef, "\$# on freed array is undef");
276     my @warn;
277     local $SIG{__WARN__} = sub {push @warn, "@_"};
278     $$ref = 1000;
279     is (scalar @warn, 1);
280     like ($warn[0], qr/^Attempt to set length of freed array/);
281 }
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 }
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
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
323     is ($$inner, undef, "orphaned $#foo is always undef");
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
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
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 }
391 {
392     # AASSIGN_COMMON detection with logical operators
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 }
398
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
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
435 *trit = *scile;  $trit[0];
436 ok(1, 'aelem_fast on a nonexistent array does not crash');
437
438 # [perl #107440]
439 sub A::DESTROY { $::ra = 0 }
440 $::ra = [ bless [], 'A' ];
441 undef @$::ra;
442 pass 'no crash when freeing array that is being undeffed';
443 $::ra = [ bless [], 'A' ];
444 @$::ra = ('a'..'z');
445 pass 'no crash when freeing array that is being cleared';
446
447 # [perl #85670] Copying magic to elements
448 SKIP: {
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 }
458 package 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
469 # Test that &PL_sv_undef is not special in arrays
470 sub {
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);
475 # and that padav also knows how to handle the resulting NULLs
476 @_ = sub { my @a; $a[1]=1; @a }->();
477 is join (" ", map $_//"undef", @_), "undef 1",
478   'returning my @a with nonexistent elements'; 
479
480 # [perl #118691]
481 @plink=@plunk=();
482 $plink[3] = 1;
483 sub {
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
500 $_ = \$#{[]};
501 $$_ = \1;
502 "$$_";
503 pass "no assertion failure after assigning ref to arylen when ary is gone";
504
505
506 {
507     # Test aelemfast for both +ve and -ve indices, both lex and package vars.
508     # Make especially careful that we don't have any edge cases around
509     # fitting an I8 into a U8.
510     my @a = (0..299);
511     is($a[-256], 300-256, 'lex -256');
512     is($a[-255], 300-255, 'lex -255');
513     is($a[-254], 300-254, 'lex -254');
514     is($a[-129], 300-129, 'lex -129');
515     is($a[-128], 300-128, 'lex -128');
516     is($a[-127], 300-127, 'lex -127');
517     is($a[-126], 300-126, 'lex -126');
518     is($a[  -1], 300-  1, 'lex   -1');
519     is($a[   0],       0, 'lex    0');
520     is($a[   1],       1, 'lex    1');
521     is($a[ 126],     126, 'lex  126');
522     is($a[ 127],     127, 'lex  127');
523     is($a[ 128],     128, 'lex  128');
524     is($a[ 129],     129, 'lex  129');
525     is($a[ 254],     254, 'lex  254');
526     is($a[ 255],     255, 'lex  255');
527     is($a[ 256],     256, 'lex  256');
528     @aelem =(0..299);
529     is($aelem[-256], 300-256, 'pkg -256');
530     is($aelem[-255], 300-255, 'pkg -255');
531     is($aelem[-254], 300-254, 'pkg -254');
532     is($aelem[-129], 300-129, 'pkg -129');
533     is($aelem[-128], 300-128, 'pkg -128');
534     is($aelem[-127], 300-127, 'pkg -127');
535     is($aelem[-126], 300-126, 'pkg -126');
536     is($aelem[  -1], 300-  1, 'pkg   -1');
537     is($aelem[   0],       0, 'pkg    0');
538     is($aelem[   1],       1, 'pkg    1');
539     is($aelem[ 126],     126, 'pkg  126');
540     is($aelem[ 127],     127, 'pkg  127');
541     is($aelem[ 128],     128, 'pkg  128');
542     is($aelem[ 129],     129, 'pkg  129');
543     is($aelem[ 254],     254, 'pkg  254');
544     is($aelem[ 255],     255, 'pkg  255');
545     is($aelem[ 256],     256, 'pkg  256');
546 }
547
548 "We're included by lib/Tie/Array/std.t so we need to return something true";