This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
c5d45d7ffe58f5fe5b59ab8ca413f5d832adbe4e
[perl5.git] / t / op / array.t
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     @INC = ('.', '../lib');
6 }
7
8 require 'test.pl';
9
10 plan (128);
11
12 #
13 # @foo, @bar, and @ary are also used from tie-stdarray after tie-ing them
14 #
15
16 @ary = (1,2,3,4,5);
17 is(join('',@ary), '12345');
18
19 $tmp = $ary[$#ary]; --$#ary;
20 is($tmp, 5);
21 is($#ary, 3);
22 is(join('',@ary), '1234');
23
24 {
25     no warnings 'deprecated';
26
27 $[ = 1;
28 @ary = (1,2,3,4,5);
29 is(join('',@ary), '12345');
30
31 $tmp = $ary[$#ary]; --$#ary;
32 is($tmp, 5);
33 # Must do == here beacuse $[ isn't 0
34 ok($#ary == 4);
35 is(join('',@ary), '1234');
36
37 is($ary[5], undef);
38
39 $#ary += 1;     # see if element 5 gone for good
40 ok($#ary == 5);
41 ok(!defined $ary[5]);
42
43 $[ = 0;
44 @foo = ();
45 $r = join(',', $#foo, @foo);
46 is($r, "-1");
47 $foo[0] = '0';
48 $r = join(',', $#foo, @foo);
49 is($r, "0,0");
50 $foo[2] = '2';
51 $r = join(',', $#foo, @foo);
52 is($r, "2,0,,2");
53 @bar = ();
54 $bar[0] = '0';
55 $bar[1] = '1';
56 $r = join(',', $#bar, @bar);
57 is($r, "1,0,1");
58 @bar = ();
59 $r = join(',', $#bar, @bar);
60 is($r, "-1");
61 $bar[0] = '0';
62 $r = join(',', $#bar, @bar);
63 is($r, "0,0");
64 $bar[2] = '2';
65 $r = join(',', $#bar, @bar);
66 is($r, "2,0,,2");
67 reset 'b' if $^O ne 'VMS';
68 @bar = ();
69 $bar[0] = '0';
70 $r = join(',', $#bar, @bar);
71 is($r, "0,0");
72 $bar[2] = '2';
73 $r = join(',', $#bar, @bar);
74 is($r, "2,0,,2");
75
76 }
77
78 $foo = 'now is the time';
79 ok(scalar (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/)));
80 is($F1, 'now');
81 is($F2, 'is');
82 is($Etc, 'the time');
83
84 $foo = 'lskjdf';
85 ok(!($cnt = (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/))))
86    or diag("$cnt $F1:$F2:$Etc");
87
88 %foo = ('blurfl','dyick','foo','bar','etc.','etc.');
89 %bar = %foo;
90 is($bar{'foo'}, 'bar');
91 %bar = ();
92 is($bar{'foo'}, undef);
93 (%bar,$a,$b) = (%foo,'how','now');
94 is($bar{'foo'}, 'bar');
95 is($bar{'how'}, 'now');
96 @bar{keys %foo} = values %foo;
97 is($bar{'foo'}, 'bar');
98 is($bar{'how'}, 'now');
99
100 @foo = grep(/e/,split(' ','now is the time for all good men to come to'));
101 is(join(' ',@foo), 'the time men come');
102
103 @foo = grep(!/e/,split(' ','now is the time for all good men to come to'));
104 is(join(' ',@foo), 'now is for all good to to');
105
106 $foo = join('',('a','b','c','d','e','f')[0..5]);
107 is($foo, 'abcdef');
108
109 $foo = join('',('a','b','c','d','e','f')[0..1]);
110 is($foo, 'ab');
111
112 $foo = join('',('a','b','c','d','e','f')[6]);
113 is($foo, '');
114
115 @foo = ('a','b','c','d','e','f')[0,2,4];
116 @bar = ('a','b','c','d','e','f')[1,3,5];
117 $foo = join('',(@foo,@bar)[0..5]);
118 is($foo, 'acebdf');
119
120 $foo = ('a','b','c','d','e','f')[0,2,4];
121 is($foo, 'e');
122
123 $foo = ('a','b','c','d','e','f')[1];
124 is($foo, 'b');
125
126 @foo = ( 'foo', 'bar', 'burbl');
127 {
128     no warnings 'deprecated';
129     push(foo, 'blah');
130 }
131 is($#foo, 3);
132
133 # various AASSIGN_COMMON checks (see newASSIGNOP() in op.c)
134
135 #curr_test(38);
136
137 @foo = @foo;
138 is("@foo", "foo bar burbl blah");                               # 38
139
140 (undef,@foo) = @foo;
141 is("@foo", "bar burbl blah");                                   # 39
142
143 @foo = ('XXX',@foo, 'YYY');
144 is("@foo", "XXX bar burbl blah YYY");                           # 40
145
146 @foo = @foo = qw(foo b\a\r bu\\rbl blah);
147 is("@foo", 'foo b\a\r bu\\rbl blah');                           # 41
148
149 @bar = @foo = qw(foo bar);                                      # 42
150 is("@foo", "foo bar");
151 is("@bar", "foo bar");                                          # 43
152
153 # try the same with local
154 # XXX tie-stdarray fails the tests involving local, so we use
155 # different variable names to escape the 'tie'
156
157 @bee = ( 'foo', 'bar', 'burbl', 'blah');
158 {
159
160     local @bee = @bee;
161     is("@bee", "foo bar burbl blah");                           # 44
162     {
163         local (undef,@bee) = @bee;
164         is("@bee", "bar burbl blah");                           # 45
165         {
166             local @bee = ('XXX',@bee,'YYY');
167             is("@bee", "XXX bar burbl blah YYY");               # 46
168             {
169                 local @bee = local(@bee) = qw(foo bar burbl blah);
170                 is("@bee", "foo bar burbl blah");               # 47
171                 {
172                     local (@bim) = local(@bee) = qw(foo bar);
173                     is("@bee", "foo bar");                      # 48
174                     is("@bim", "foo bar");                      # 49
175                 }
176                 is("@bee", "foo bar burbl blah");               # 50
177             }
178             is("@bee", "XXX bar burbl blah YYY");               # 51
179         }
180         is("@bee", "bar burbl blah");                           # 52
181     }
182     is("@bee", "foo bar burbl blah");                           # 53
183 }
184
185 # try the same with my
186 {
187     my @bee = @bee;
188     is("@bee", "foo bar burbl blah");                           # 54
189     {
190         my (undef,@bee) = @bee;
191         is("@bee", "bar burbl blah");                           # 55
192         {
193             my @bee = ('XXX',@bee,'YYY');
194             is("@bee", "XXX bar burbl blah YYY");               # 56
195             {
196                 my @bee = my @bee = qw(foo bar burbl blah);
197                 is("@bee", "foo bar burbl blah");               # 57
198                 {
199                     my (@bim) = my(@bee) = qw(foo bar);
200                     is("@bee", "foo bar");                      # 58
201                     is("@bim", "foo bar");                      # 59
202                 }
203                 is("@bee", "foo bar burbl blah");               # 60
204             }
205             is("@bee", "XXX bar burbl blah YYY");               # 61
206         }
207         is("@bee", "bar burbl blah");                           # 62
208     }
209     is("@bee", "foo bar burbl blah");                           # 63
210 }
211
212 # try the same with our (except that previous values aren't restored)
213 {
214     our @bee = @bee;
215     is("@bee", "foo bar burbl blah");
216     {
217         our (undef,@bee) = @bee;
218         is("@bee", "bar burbl blah");
219         {
220             our @bee = ('XXX',@bee,'YYY');
221             is("@bee", "XXX bar burbl blah YYY");
222             {
223                 our @bee = our @bee = qw(foo bar burbl blah);
224                 is("@bee", "foo bar burbl blah");
225                 {
226                     our (@bim) = our(@bee) = qw(foo bar);
227                     is("@bee", "foo bar");
228                     is("@bim", "foo bar");
229                 }
230             }
231         }
232     }
233 }
234
235 # make sure reification behaves
236 my $t = curr_test();
237 sub reify { $_[1] = $t++; print "@_\n"; }
238 reify('ok');
239 reify('ok');
240
241 curr_test($t);
242
243 # qw() is no longer a runtime split, it's compiletime.
244 is (qw(foo bar snorfle)[2], 'snorfle');
245
246 @ary = (12,23,34,45,56);
247
248 is(shift(@ary), 12);
249 is(pop(@ary), 56);
250 is(push(@ary,56), 4);
251 is(unshift(@ary,12), 5);
252
253 sub foo { "a" }
254 @foo=(foo())[0,0];
255 is ($foo[1], "a");
256
257 # $[ should have the same effect regardless of whether the aelem
258 #    op is optimized to aelemfast.
259
260
261
262 sub tary {
263   no warnings 'deprecated';
264   local $[ = 10;
265   my $five = 5;
266   is ($tary[5], $tary[$five]);
267 }
268
269 @tary = (0..50);
270 tary();
271
272
273 # bugid #15439 - clearing an array calls destructors which may try
274 # to modify the array - caused 'Attempt to free unreferenced scalar'
275
276 my $got = runperl (
277         prog => q{
278                     sub X::DESTROY { @a = () }
279                     @a = (bless {}, q{X});
280                     @a = ();
281                 },
282         stderr => 1
283     );
284
285 $got =~ s/\n/ /g;
286 is ($got, '');
287
288 # Test negative and funky indices.
289
290
291 {
292     my @a = 0..4;
293     is($a[-1], 4);
294     is($a[-2], 3);
295     is($a[-5], 0);
296     ok(!defined $a[-6]);
297
298     is($a[2.1]  , 2);
299     is($a[2.9]  , 2);
300     is($a[undef], 0);
301     is($a["3rd"], 3);
302 }
303
304
305 {
306     my @a;
307     eval '$a[-1] = 0';
308     like($@, qr/Modification of non-creatable array value attempted, subscript -1/, "\$a[-1] = 0");
309 }
310
311 sub test_arylen {
312     my $ref = shift;
313     local $^W = 1;
314     is ($$ref, undef, "\$# on freed array is undef");
315     my @warn;
316     local $SIG{__WARN__} = sub {push @warn, "@_"};
317     $$ref = 1000;
318     is (scalar @warn, 1);
319     like ($warn[0], qr/^Attempt to set length of freed array/);
320 }
321
322 {
323     my $a = \$#{[]};
324     # Need a new statement to make it go out of scope
325     test_arylen ($a);
326     test_arylen (do {my @a; \$#a});
327 }
328
329 {
330     use vars '@array';
331
332     my $outer = \$#array;
333     is ($$outer, -1);
334     is (scalar @array, 0);
335
336     $$outer = 3;
337     is ($$outer, 3);
338     is (scalar @array, 4);
339
340     my $ref = \@array;
341
342     my $inner;
343     {
344         local @array;
345         $inner = \$#array;
346
347         is ($$inner, -1);
348         is (scalar @array, 0);
349         $$outer = 6;
350
351         is (scalar @$ref, 7);
352
353         is ($$inner, -1);
354         is (scalar @array, 0);
355
356         $$inner = 42;
357     }
358
359     is (scalar @array, 7);
360     is ($$outer, 6);
361
362     is ($$inner, undef, "orphaned $#foo is always undef");
363
364     is (scalar @array, 7);
365     is ($$outer, 6);
366
367     $$inner = 1;
368
369     is (scalar @array, 7);
370     is ($$outer, 6);
371
372     $$inner = 503; # Bang!
373
374     is (scalar @array, 7);
375     is ($$outer, 6);
376 }
377
378 {
379     # Bug #36211
380     use vars '@array';
381     for (1,2) {
382         {
383             local @a;
384             is ($#a, -1);
385             @a=(1..4)
386         }
387     }
388 }
389
390 {
391     # Bug #37350
392     my @array = (1..4);
393     $#{@array} = 7;
394     is ($#{4}, 7);
395
396     my $x;
397     $#{$x} = 3;
398     is(scalar @$x, 4);
399
400     push @{@array}, 23;
401     is ($4[8], 23);
402 }
403 {
404     # Bug #37350 -- once more with a global
405     use vars '@array';
406     @array = (1..4);
407     $#{@array} = 7;
408     is ($#{4}, 7);
409
410     my $x;
411     $#{$x} = 3;
412     is(scalar @$x, 4);
413
414     push @{@array}, 23;
415     is ($4[8], 23);
416 }
417
418 # more tests for AASSIGN_COMMON
419
420 {
421     our($x,$y,$z) = (1..3);
422     our($y,$z) = ($x,$y);
423     is("$x $y $z", "1 1 2");
424 }
425 {
426     our($x,$y,$z) = (1..3);
427     (our $y, our $z) = ($x,$y);
428     is("$x $y $z", "1 1 2");
429 }
430
431 # [perl #70171]
432 {
433  my $x = get_x(); my %x = %$x; sub get_x { %x=(1..4); return \%x };
434  is(
435    join(" ", map +($_,$x{$_}), sort keys %x), "1 2 3 4",
436   'bug 70171 (self-assignment via my %x = %$x)'
437  );
438  my $y = get_y(); my @y = @$y; sub get_y { @y=(1..4); return \@y };
439  is(
440   "@y", "1 2 3 4",
441   'bug 70171 (self-assignment via my @x = @$x)'
442  );
443 }
444
445 *trit = *scile;  $trit[0];
446 ok(1, 'aelem_fast on a nonexistent array does not crash');
447
448 "We're included by lib/Tie/Array/std.t so we need to return something true";