Small optimisations, by Brandon Black
[p5sagit/p5-mst-13.2.git] / t / op / array.t
CommitLineData
a687059c 1#!./perl
2
6b42d12b 3BEGIN {
4 chdir 't' if -d 't';
404a4710 5 @INC = ('.', '../lib');
6b42d12b 6}
7
0dd3f902 8require 'test.pl';
9
f17e6c41 10plan (125);
a687059c 11
05fc92f1 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 18
19$tmp = $ary[$#ary]; --$#ary;
0dd3f902 20is($tmp, 5);
21is($#ary, 3);
22is(join('',@ary), '1234');
a687059c 23
24$[ = 1;
25@ary = (1,2,3,4,5);
0dd3f902 26is(join('',@ary), '12345');
a687059c 27
28$tmp = $ary[$#ary]; --$#ary;
0dd3f902 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 37ok($#ary == 5);
38ok(!defined $ary[5]);
a687059c 39
40$[ = 0;
41@foo = ();
42$r = join(',', $#foo, @foo);
0dd3f902 43is($r, "-1");
a687059c 44$foo[0] = '0';
45$r = join(',', $#foo, @foo);
0dd3f902 46is($r, "0,0");
a687059c 47$foo[2] = '2';
48$r = join(',', $#foo, @foo);
0dd3f902 49is($r, "2,0,,2");
a687059c 50@bar = ();
51$bar[0] = '0';
52$bar[1] = '1';
53$r = join(',', $#bar, @bar);
0dd3f902 54is($r, "1,0,1");
a687059c 55@bar = ();
56$r = join(',', $#bar, @bar);
0dd3f902 57is($r, "-1");
a687059c 58$bar[0] = '0';
59$r = join(',', $#bar, @bar);
0dd3f902 60is($r, "0,0");
a687059c 61$bar[2] = '2';
62$r = join(',', $#bar, @bar);
0dd3f902 63is($r, "2,0,,2");
14ce8c55 64reset 'b' if $^O ne 'VMS';
a687059c 65@bar = ();
66$bar[0] = '0';
67$r = join(',', $#bar, @bar);
0dd3f902 68is($r, "0,0");
a687059c 69$bar[2] = '2';
70$r = join(',', $#bar, @bar);
0dd3f902 71is($r, "2,0,,2");
a687059c 72
73$foo = 'now is the time';
0dd3f902 74ok(scalar (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/)));
75is($F1, 'now');
76is($F2, 'is');
77is($Etc, 'the time');
a687059c 78
79$foo = 'lskjdf';
0dd3f902 80ok(!($cnt = (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/))))
81 or diag("$cnt $F1:$F2:$Etc");
a687059c 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 89is($bar{'foo'}, 'bar');
90is($bar{'how'}, 'now');
a687059c 91@bar{keys %foo} = values %foo;
0dd3f902 92is($bar{'foo'}, 'bar');
93is($bar{'how'}, 'now');
a687059c 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 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 100
101$foo = join('',('a','b','c','d','e','f')[0..5]);
0dd3f902 102is($foo, 'abcdef');
79a0689e 103
104$foo = join('',('a','b','c','d','e','f')[0..1]);
0dd3f902 105is($foo, 'ab');
79a0689e 106
107$foo = join('',('a','b','c','d','e','f')[6]);
0dd3f902 108is($foo, '');
79a0689e 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 114
115$foo = ('a','b','c','d','e','f')[0,2,4];
0dd3f902 116is($foo, 'e');
79a0689e 117
118$foo = ('a','b','c','d','e','f')[1];
0dd3f902 119is($foo, 'b');
a0231f0e 120
c6aa4a32 121@foo = ( 'foo', 'bar', 'burbl');
122push(foo, 'blah');
0dd3f902 123is($#foo, 3);
b3381831 124
125# various AASSIGN_COMMON checks (see newASSIGNOP() in op.c)
126
0dd3f902 127#curr_test(38);
b3381831 128
129@foo = @foo;
0dd3f902 130is("@foo", "foo bar burbl blah"); # 38
b3381831 131
132(undef,@foo) = @foo;
0dd3f902 133is("@foo", "bar burbl blah"); # 39
b3381831 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 140
141@bar = @foo = qw(foo bar); # 42
0dd3f902 142is("@foo", "foo bar");
143is("@bar", "foo bar"); # 43
b3381831 144
145# try the same with local
05fc92f1 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 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 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 175}
176
177# try the same with my
178{
05fc92f1 179 my @bee = @bee;
0dd3f902 180 is("@bee", "foo bar burbl blah"); # 54
b3381831 181 {
05fc92f1 182 my (undef,@bee) = @bee;
0dd3f902 183 is("@bee", "bar burbl blah"); # 55
b3381831 184 {
05fc92f1 185 my @bee = ('XXX',@bee,'YYY');
0dd3f902 186 is("@bee", "XXX bar burbl blah YYY"); # 56
b3381831 187 {
05fc92f1 188 my @bee = my @bee = qw(foo bar burbl blah);
0dd3f902 189 is("@bee", "foo bar burbl blah"); # 57
b3381831 190 {
05fc92f1 191 my (@bim) = my(@bee) = qw(foo bar);
0dd3f902 192 is("@bee", "foo bar"); # 58
193 is("@bim", "foo bar"); # 59
b3381831 194 }
0dd3f902 195 is("@bee", "foo bar burbl blah"); # 60
b3381831 196 }
0dd3f902 197 is("@bee", "XXX bar burbl blah YYY"); # 61
b3381831 198 }
0dd3f902 199 is("@bee", "bar burbl blah"); # 62
b3381831 200 }
0dd3f902 201 is("@bee", "foo bar burbl blah"); # 63
b3381831 202}
203
f17e6c41 204# try the same with our (except that previous values aren't restored)
205{
206 our @bee = @bee;
207 is("@bee", "foo bar burbl blah");
208 {
209 our (undef,@bee) = @bee;
210 is("@bee", "bar burbl blah");
211 {
212 our @bee = ('XXX',@bee,'YYY');
213 is("@bee", "XXX bar burbl blah YYY");
214 {
215 our @bee = our @bee = qw(foo bar burbl blah);
216 is("@bee", "foo bar burbl blah");
217 {
218 our (@bim) = our(@bee) = qw(foo bar);
219 is("@bee", "foo bar");
220 is("@bim", "foo bar");
221 }
222 }
223 }
224 }
225}
226
352edd90 227# make sure reification behaves
0dd3f902 228my $t = curr_test();
229sub reify { $_[1] = $t++; print "@_\n"; }
352edd90 230reify('ok');
231reify('ok');
9d001be8 232
0dd3f902 233curr_test($t);
7517970f 234
0dd3f902 235# qw() is no longer a runtime split, it's compiletime.
236is (qw(foo bar snorfle)[2], 'snorfle');
7517970f 237
0dd3f902 238@ary = (12,23,34,45,56);
7517970f 239
0dd3f902 240is(shift(@ary), 12);
241is(pop(@ary), 56);
242is(push(@ary,56), 4);
243is(unshift(@ary,12), 5);
4c8f17b9 244
245sub foo { "a" }
246@foo=(foo())[0,0];
0dd3f902 247is ($foo[1], "a");
b0840a2a 248
249# $[ should have the same effect regardless of whether the aelem
250# op is optimized to aelemfast.
251
0dd3f902 252
253
b0840a2a 254sub tary {
255 local $[ = 10;
256 my $five = 5;
0dd3f902 257 is ($tary[5], $tary[$five]);
b0840a2a 258}
259
260@tary = (0..50);
261tary();
6b42d12b 262
263
6b42d12b 264# bugid #15439 - clearing an array calls destructors which may try
265# to modify the array - caused 'Attempt to free unreferenced scalar'
266
267my $got = runperl (
268 prog => q{
269 sub X::DESTROY { @a = () }
270 @a = (bless {}, 'X');
271 @a = ();
272 },
273 stderr => 1
274 );
275
276$got =~ s/\n/ /g;
0dd3f902 277is ($got, '');
2b573ace 278
279# Test negative and funky indices.
280
0dd3f902 281
2b573ace 282{
283 my @a = 0..4;
0dd3f902 284 is($a[-1], 4);
285 is($a[-2], 3);
286 is($a[-5], 0);
287 ok(!defined $a[-6]);
288
289 is($a[2.1] , 2);
290 is($a[2.9] , 2);
291 is($a[undef], 0);
292 is($a["3rd"], 3);
2b573ace 293}
294
2b573ace 295
296{
297 my @a;
298 eval '$a[-1] = 0';
0dd3f902 299 like($@, qr/Modification of non-creatable array value attempted, subscript -1/, "\$a[-1] = 0");
2b573ace 300}
0dd3f902 301
1b20cd17 302sub test_arylen {
303 my $ref = shift;
83bf042f 304 local $^W = 1;
1b20cd17 305 is ($$ref, undef, "\$# on freed array is undef");
83bf042f 306 my @warn;
307 local $SIG{__WARN__} = sub {push @warn, "@_"};
1b20cd17 308 $$ref = 1000;
83bf042f 309 is (scalar @warn, 1);
310 like ($warn[0], qr/^Attempt to set length of freed array/);
311}
1b20cd17 312
313{
314 my $a = \$#{[]};
315 # Need a new statement to make it go out of scope
316 test_arylen ($a);
317 test_arylen (do {my @a; \$#a});
318}
404a4710 319
320{
321 use vars '@array';
322
323 my $outer = \$#array;
324 is ($$outer, -1);
325 is (scalar @array, 0);
326
327 $$outer = 3;
328 is ($$outer, 3);
329 is (scalar @array, 4);
330
331 my $ref = \@array;
332
404a4710 333 my $inner;
334 {
335 local @array;
336 $inner = \$#array;
337
338 is ($$inner, -1);
339 is (scalar @array, 0);
340 $$outer = 6;
341
342 is (scalar @$ref, 7);
343
344 is ($$inner, -1);
345 is (scalar @array, 0);
346
347 $$inner = 42;
348 }
349
350 is (scalar @array, 7);
351 is ($$outer, 6);
352
2fc04a10 353 is ($$inner, undef, "orphaned $#foo is always undef");
404a4710 354
355 is (scalar @array, 7);
356 is ($$outer, 6);
357
358 $$inner = 1;
359
360 is (scalar @array, 7);
361 is ($$outer, 6);
362
363 $$inner = 503; # Bang!
364
365 is (scalar @array, 7);
366 is ($$outer, 6);
367}
368
369{
370 # Bug #36211
371 use vars '@array';
372 for (1,2) {
373 {
374 local @a;
375 is ($#a, -1);
376 @a=(1..4)
377 }
378 }
379}
380
e4c5ccf3 381{
382 # Bug #37350
383 my @array = (1..4);
384 $#{@array} = 7;
385 is ($#{4}, 7);
386
387 my $x;
388 $#{$x} = 3;
389 is(scalar @$x, 4);
390
391 push @{@array}, 23;
392 is ($4[8], 23);
393}
394{
395 # Bug #37350 -- once more with a global
396 use vars '@array';
397 @array = (1..4);
398 $#{@array} = 7;
399 is ($#{4}, 7);
400
401 my $x;
402 $#{$x} = 3;
403 is(scalar @$x, 4);
404
405 push @{@array}, 23;
406 is ($4[8], 23);
407}
408
f17e6c41 409# more tests for AASSIGN_COMMON
410
411{
412 our($x,$y,$z) = (1..3);
413 our($y,$z) = ($x,$y);
414 is("$x $y $z", "1 1 2");
415}
416{
417 our($x,$y,$z) = (1..3);
418 (our $y, our $z) = ($x,$y);
419 is("$x $y $z", "1 1 2");
420}
421
422
404a4710 423"We're included by lib/Tie/Array/std.t so we need to return something true";