This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Forgotten chunk by jhi
[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');
6b42d12b
DM
6}
7
0dd3f902
NC
8require 'test.pl';
9
404a4710 10plan (111);
a687059c 11
05fc92f1
GS
12#
13# @foo, @bar, and @ary are also used from tie-stdarray after tie-ing them
14#
15
a687059c 16@ary = (1,2,3,4,5);
0dd3f902 17is(join('',@ary), '12345');
a687059c
LW
18
19$tmp = $ary[$#ary]; --$#ary;
0dd3f902
NC
20is($tmp, 5);
21is($#ary, 3);
22is(join('',@ary), '1234');
a687059c
LW
23
24$[ = 1;
25@ary = (1,2,3,4,5);
0dd3f902 26is(join('',@ary), '12345');
a687059c
LW
27
28$tmp = $ary[$#ary]; --$#ary;
0dd3f902
NC
29is($tmp, 5);
30# Must do == here beacuse $[ isn't 0
31ok($#ary == 4);
32is(join('',@ary), '1234');
a687059c 33
0dd3f902 34is($ary[5], undef);
a687059c 35
a0d0e21e 36$#ary += 1; # see if element 5 gone for good
0dd3f902
NC
37ok($#ary == 5);
38ok(!defined $ary[5]);
a687059c
LW
39
40$[ = 0;
41@foo = ();
42$r = join(',', $#foo, @foo);
0dd3f902 43is($r, "-1");
a687059c
LW
44$foo[0] = '0';
45$r = join(',', $#foo, @foo);
0dd3f902 46is($r, "0,0");
a687059c
LW
47$foo[2] = '2';
48$r = join(',', $#foo, @foo);
0dd3f902 49is($r, "2,0,,2");
a687059c
LW
50@bar = ();
51$bar[0] = '0';
52$bar[1] = '1';
53$r = join(',', $#bar, @bar);
0dd3f902 54is($r, "1,0,1");
a687059c
LW
55@bar = ();
56$r = join(',', $#bar, @bar);
0dd3f902 57is($r, "-1");
a687059c
LW
58$bar[0] = '0';
59$r = join(',', $#bar, @bar);
0dd3f902 60is($r, "0,0");
a687059c
LW
61$bar[2] = '2';
62$r = join(',', $#bar, @bar);
0dd3f902 63is($r, "2,0,,2");
a687059c
LW
64reset 'b';
65@bar = ();
66$bar[0] = '0';
67$r = join(',', $#bar, @bar);
0dd3f902 68is($r, "0,0");
a687059c
LW
69$bar[2] = '2';
70$r = join(',', $#bar, @bar);
0dd3f902 71is($r, "2,0,,2");
a687059c
LW
72
73$foo = 'now is the time';
0dd3f902
NC
74ok(scalar (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/)));
75is($F1, 'now');
76is($F2, 'is');
77is($Etc, 'the time');
a687059c
LW
78
79$foo = 'lskjdf';
0dd3f902
NC
80ok(!($cnt = (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/))))
81 or diag("$cnt $F1:$F2:$Etc");
a687059c
LW
82
83%foo = ('blurfl','dyick','foo','bar','etc.','etc.');
84%bar = %foo;
0dd3f902 85is($bar{'foo'}, 'bar');
a687059c 86%bar = ();
0dd3f902 87is($bar{'foo'}, undef);
a687059c 88(%bar,$a,$b) = (%foo,'how','now');
0dd3f902
NC
89is($bar{'foo'}, 'bar');
90is($bar{'how'}, 'now');
a687059c 91@bar{keys %foo} = values %foo;
0dd3f902
NC
92is($bar{'foo'}, 'bar');
93is($bar{'how'}, 'now');
a687059c
LW
94
95@foo = grep(/e/,split(' ','now is the time for all good men to come to'));
0dd3f902 96is(join(' ',@foo), 'the time men come');
a687059c
LW
97
98@foo = grep(!/e/,split(' ','now is the time for all good men to come to'));
0dd3f902 99is(join(' ',@foo), 'now is for all good to to');
79a0689e
LW
100
101$foo = join('',('a','b','c','d','e','f')[0..5]);
0dd3f902 102is($foo, 'abcdef');
79a0689e
LW
103
104$foo = join('',('a','b','c','d','e','f')[0..1]);
0dd3f902 105is($foo, 'ab');
79a0689e
LW
106
107$foo = join('',('a','b','c','d','e','f')[6]);
0dd3f902 108is($foo, '');
79a0689e
LW
109
110@foo = ('a','b','c','d','e','f')[0,2,4];
111@bar = ('a','b','c','d','e','f')[1,3,5];
112$foo = join('',(@foo,@bar)[0..5]);
0dd3f902 113is($foo, 'acebdf');
79a0689e
LW
114
115$foo = ('a','b','c','d','e','f')[0,2,4];
0dd3f902 116is($foo, 'e');
79a0689e
LW
117
118$foo = ('a','b','c','d','e','f')[1];
0dd3f902 119is($foo, 'b');
a0231f0e 120
c6aa4a32
SP
121@foo = ( 'foo', 'bar', 'burbl');
122push(foo, 'blah');
0dd3f902 123is($#foo, 3);
b3381831
GS
124
125# various AASSIGN_COMMON checks (see newASSIGNOP() in op.c)
126
0dd3f902 127#curr_test(38);
b3381831
GS
128
129@foo = @foo;
0dd3f902 130is("@foo", "foo bar burbl blah"); # 38
b3381831
GS
131
132(undef,@foo) = @foo;
0dd3f902 133is("@foo", "bar burbl blah"); # 39
b3381831
GS
134
135@foo = ('XXX',@foo, 'YYY');
0dd3f902 136is("@foo", "XXX bar burbl blah YYY"); # 40
b3381831 137
3201ebbd 138@foo = @foo = qw(foo b\a\r bu\\rbl blah);
0dd3f902 139is("@foo", 'foo b\a\r bu\\rbl blah'); # 41
b3381831
GS
140
141@bar = @foo = qw(foo bar); # 42
0dd3f902
NC
142is("@foo", "foo bar");
143is("@bar", "foo bar"); # 43
b3381831
GS
144
145# try the same with local
05fc92f1
GS
146# XXX tie-stdarray fails the tests involving local, so we use
147# different variable names to escape the 'tie'
148
149@bee = ( 'foo', 'bar', 'burbl', 'blah');
b3381831
GS
150{
151
05fc92f1 152 local @bee = @bee;
0dd3f902 153 is("@bee", "foo bar burbl blah"); # 44
b3381831 154 {
05fc92f1 155 local (undef,@bee) = @bee;
0dd3f902 156 is("@bee", "bar burbl blah"); # 45
b3381831 157 {
05fc92f1 158 local @bee = ('XXX',@bee,'YYY');
0dd3f902 159 is("@bee", "XXX bar burbl blah YYY"); # 46
b3381831 160 {
05fc92f1 161 local @bee = local(@bee) = qw(foo bar burbl blah);
0dd3f902 162 is("@bee", "foo bar burbl blah"); # 47
b3381831 163 {
05fc92f1 164 local (@bim) = local(@bee) = qw(foo bar);
0dd3f902
NC
165 is("@bee", "foo bar"); # 48
166 is("@bim", "foo bar"); # 49
b3381831 167 }
0dd3f902 168 is("@bee", "foo bar burbl blah"); # 50
b3381831 169 }
0dd3f902 170 is("@bee", "XXX bar burbl blah YYY"); # 51
b3381831 171 }
0dd3f902 172 is("@bee", "bar burbl blah"); # 52
b3381831 173 }
0dd3f902 174 is("@bee", "foo bar burbl blah"); # 53
b3381831
GS
175}
176
177# try the same with my
178{
179
05fc92f1 180 my @bee = @bee;
0dd3f902 181 is("@bee", "foo bar burbl blah"); # 54
b3381831 182 {
05fc92f1 183 my (undef,@bee) = @bee;
0dd3f902 184 is("@bee", "bar burbl blah"); # 55
b3381831 185 {
05fc92f1 186 my @bee = ('XXX',@bee,'YYY');
0dd3f902 187 is("@bee", "XXX bar burbl blah YYY"); # 56
b3381831 188 {
05fc92f1 189 my @bee = my @bee = qw(foo bar burbl blah);
0dd3f902 190 is("@bee", "foo bar burbl blah"); # 57
b3381831 191 {
05fc92f1 192 my (@bim) = my(@bee) = qw(foo bar);
0dd3f902
NC
193 is("@bee", "foo bar"); # 58
194 is("@bim", "foo bar"); # 59
b3381831 195 }
0dd3f902 196 is("@bee", "foo bar burbl blah"); # 60
b3381831 197 }
0dd3f902 198 is("@bee", "XXX bar burbl blah YYY"); # 61
b3381831 199 }
0dd3f902 200 is("@bee", "bar burbl blah"); # 62
b3381831 201 }
0dd3f902 202 is("@bee", "foo bar burbl blah"); # 63
b3381831
GS
203}
204
352edd90 205# make sure reification behaves
0dd3f902
NC
206my $t = curr_test();
207sub reify { $_[1] = $t++; print "@_\n"; }
352edd90
GS
208reify('ok');
209reify('ok');
9d001be8 210
0dd3f902 211curr_test($t);
7517970f 212
0dd3f902
NC
213# qw() is no longer a runtime split, it's compiletime.
214is (qw(foo bar snorfle)[2], 'snorfle');
7517970f 215
0dd3f902 216@ary = (12,23,34,45,56);
7517970f 217
0dd3f902
NC
218is(shift(@ary), 12);
219is(pop(@ary), 56);
220is(push(@ary,56), 4);
221is(unshift(@ary,12), 5);
4c8f17b9
BH
222
223sub foo { "a" }
224@foo=(foo())[0,0];
0dd3f902 225is ($foo[1], "a");
b0840a2a
RH
226
227# $[ should have the same effect regardless of whether the aelem
228# op is optimized to aelemfast.
229
0dd3f902
NC
230
231
b0840a2a
RH
232sub tary {
233 local $[ = 10;
234 my $five = 5;
0dd3f902 235 is ($tary[5], $tary[$five]);
b0840a2a
RH
236}
237
238@tary = (0..50);
239tary();
6b42d12b
DM
240
241
6b42d12b
DM
242# bugid #15439 - clearing an array calls destructors which may try
243# to modify the array - caused 'Attempt to free unreferenced scalar'
244
245my $got = runperl (
246 prog => q{
247 sub X::DESTROY { @a = () }
248 @a = (bless {}, 'X');
249 @a = ();
250 },
251 stderr => 1
252 );
253
254$got =~ s/\n/ /g;
0dd3f902 255is ($got, '');
2b573ace
JH
256
257# Test negative and funky indices.
258
0dd3f902 259
2b573ace
JH
260{
261 my @a = 0..4;
0dd3f902
NC
262 is($a[-1], 4);
263 is($a[-2], 3);
264 is($a[-5], 0);
265 ok(!defined $a[-6]);
266
267 is($a[2.1] , 2);
268 is($a[2.9] , 2);
269 is($a[undef], 0);
270 is($a["3rd"], 3);
2b573ace
JH
271}
272
2b573ace
JH
273
274{
275 my @a;
276 eval '$a[-1] = 0';
0dd3f902 277 like($@, qr/Modification of non-creatable array value attempted, subscript -1/, "\$a[-1] = 0");
2b573ace 278}
0dd3f902 279
1b20cd17
NC
280sub test_arylen {
281 my $ref = shift;
83bf042f 282 local $^W = 1;
1b20cd17 283 is ($$ref, undef, "\$# on freed array is undef");
83bf042f
NC
284 my @warn;
285 local $SIG{__WARN__} = sub {push @warn, "@_"};
1b20cd17 286 $$ref = 1000;
83bf042f
NC
287 is (scalar @warn, 1);
288 like ($warn[0], qr/^Attempt to set length of freed array/);
289}
1b20cd17
NC
290
291{
292 my $a = \$#{[]};
293 # Need a new statement to make it go out of scope
294 test_arylen ($a);
295 test_arylen (do {my @a; \$#a});
296}
404a4710
NC
297
298{
299 use vars '@array';
300
301 my $outer = \$#array;
302 is ($$outer, -1);
303 is (scalar @array, 0);
304
305 $$outer = 3;
306 is ($$outer, 3);
307 is (scalar @array, 4);
308
309 my $ref = \@array;
310
404a4710
NC
311 my $inner;
312 {
313 local @array;
314 $inner = \$#array;
315
316 is ($$inner, -1);
317 is (scalar @array, 0);
318 $$outer = 6;
319
320 is (scalar @$ref, 7);
321
322 is ($$inner, -1);
323 is (scalar @array, 0);
324
325 $$inner = 42;
326 }
327
328 is (scalar @array, 7);
329 is ($$outer, 6);
330
2fc04a10 331 is ($$inner, undef, "orphaned $#foo is always undef");
404a4710
NC
332
333 is (scalar @array, 7);
334 is ($$outer, 6);
335
336 $$inner = 1;
337
338 is (scalar @array, 7);
339 is ($$outer, 6);
340
341 $$inner = 503; # Bang!
342
343 is (scalar @array, 7);
344 is ($$outer, 6);
345}
346
347{
348 # Bug #36211
349 use vars '@array';
350 for (1,2) {
351 {
352 local @a;
353 is ($#a, -1);
354 @a=(1..4)
355 }
356 }
357}
358
359"We're included by lib/Tie/Array/std.t so we need to return something true";