Commit | Line | Data |
---|---|---|
a687059c LW |
1 | #!./perl |
2 | ||
6b42d12b DM |
3 | BEGIN { |
4 | chdir 't' if -d 't'; | |
404a4710 | 5 | @INC = ('.', '../lib'); |
6b42d12b DM |
6 | } |
7 | ||
0dd3f902 NC |
8 | require 'test.pl'; |
9 | ||
f17e6c41 | 10 | plan (125); |
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 | 17 | is(join('',@ary), '12345'); |
a687059c LW |
18 | |
19 | $tmp = $ary[$#ary]; --$#ary; | |
0dd3f902 NC |
20 | is($tmp, 5); |
21 | is($#ary, 3); | |
22 | is(join('',@ary), '1234'); | |
a687059c LW |
23 | |
24 | $[ = 1; | |
25 | @ary = (1,2,3,4,5); | |
0dd3f902 | 26 | is(join('',@ary), '12345'); |
a687059c LW |
27 | |
28 | $tmp = $ary[$#ary]; --$#ary; | |
0dd3f902 NC |
29 | is($tmp, 5); |
30 | # Must do == here beacuse $[ isn't 0 | |
31 | ok($#ary == 4); | |
32 | is(join('',@ary), '1234'); | |
a687059c | 33 | |
0dd3f902 | 34 | is($ary[5], undef); |
a687059c | 35 | |
a0d0e21e | 36 | $#ary += 1; # see if element 5 gone for good |
0dd3f902 NC |
37 | ok($#ary == 5); |
38 | ok(!defined $ary[5]); | |
a687059c LW |
39 | |
40 | $[ = 0; | |
41 | @foo = (); | |
42 | $r = join(',', $#foo, @foo); | |
0dd3f902 | 43 | is($r, "-1"); |
a687059c LW |
44 | $foo[0] = '0'; |
45 | $r = join(',', $#foo, @foo); | |
0dd3f902 | 46 | is($r, "0,0"); |
a687059c LW |
47 | $foo[2] = '2'; |
48 | $r = join(',', $#foo, @foo); | |
0dd3f902 | 49 | is($r, "2,0,,2"); |
a687059c LW |
50 | @bar = (); |
51 | $bar[0] = '0'; | |
52 | $bar[1] = '1'; | |
53 | $r = join(',', $#bar, @bar); | |
0dd3f902 | 54 | is($r, "1,0,1"); |
a687059c LW |
55 | @bar = (); |
56 | $r = join(',', $#bar, @bar); | |
0dd3f902 | 57 | is($r, "-1"); |
a687059c LW |
58 | $bar[0] = '0'; |
59 | $r = join(',', $#bar, @bar); | |
0dd3f902 | 60 | is($r, "0,0"); |
a687059c LW |
61 | $bar[2] = '2'; |
62 | $r = join(',', $#bar, @bar); | |
0dd3f902 | 63 | is($r, "2,0,,2"); |
14ce8c55 | 64 | reset 'b' if $^O ne 'VMS'; |
a687059c LW |
65 | @bar = (); |
66 | $bar[0] = '0'; | |
67 | $r = join(',', $#bar, @bar); | |
0dd3f902 | 68 | is($r, "0,0"); |
a687059c LW |
69 | $bar[2] = '2'; |
70 | $r = join(',', $#bar, @bar); | |
0dd3f902 | 71 | is($r, "2,0,,2"); |
a687059c LW |
72 | |
73 | $foo = 'now is the time'; | |
0dd3f902 NC |
74 | ok(scalar (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/))); |
75 | is($F1, 'now'); | |
76 | is($F2, 'is'); | |
77 | is($Etc, 'the time'); | |
a687059c LW |
78 | |
79 | $foo = 'lskjdf'; | |
0dd3f902 NC |
80 | ok(!($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 | 85 | is($bar{'foo'}, 'bar'); |
a687059c | 86 | %bar = (); |
0dd3f902 | 87 | is($bar{'foo'}, undef); |
a687059c | 88 | (%bar,$a,$b) = (%foo,'how','now'); |
0dd3f902 NC |
89 | is($bar{'foo'}, 'bar'); |
90 | is($bar{'how'}, 'now'); | |
a687059c | 91 | @bar{keys %foo} = values %foo; |
0dd3f902 NC |
92 | is($bar{'foo'}, 'bar'); |
93 | is($bar{'how'}, 'now'); | |
a687059c LW |
94 | |
95 | @foo = grep(/e/,split(' ','now is the time for all good men to come to')); | |
0dd3f902 | 96 | is(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 | 99 | is(join(' ',@foo), 'now is for all good to to'); |
79a0689e LW |
100 | |
101 | $foo = join('',('a','b','c','d','e','f')[0..5]); | |
0dd3f902 | 102 | is($foo, 'abcdef'); |
79a0689e LW |
103 | |
104 | $foo = join('',('a','b','c','d','e','f')[0..1]); | |
0dd3f902 | 105 | is($foo, 'ab'); |
79a0689e LW |
106 | |
107 | $foo = join('',('a','b','c','d','e','f')[6]); | |
0dd3f902 | 108 | is($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 | 113 | is($foo, 'acebdf'); |
79a0689e LW |
114 | |
115 | $foo = ('a','b','c','d','e','f')[0,2,4]; | |
0dd3f902 | 116 | is($foo, 'e'); |
79a0689e LW |
117 | |
118 | $foo = ('a','b','c','d','e','f')[1]; | |
0dd3f902 | 119 | is($foo, 'b'); |
a0231f0e | 120 | |
c6aa4a32 SP |
121 | @foo = ( 'foo', 'bar', 'burbl'); |
122 | push(foo, 'blah'); | |
0dd3f902 | 123 | is($#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 | 130 | is("@foo", "foo bar burbl blah"); # 38 |
b3381831 GS |
131 | |
132 | (undef,@foo) = @foo; | |
0dd3f902 | 133 | is("@foo", "bar burbl blah"); # 39 |
b3381831 GS |
134 | |
135 | @foo = ('XXX',@foo, 'YYY'); | |
0dd3f902 | 136 | is("@foo", "XXX bar burbl blah YYY"); # 40 |
b3381831 | 137 | |
3201ebbd | 138 | @foo = @foo = qw(foo b\a\r bu\\rbl blah); |
0dd3f902 | 139 | is("@foo", 'foo b\a\r bu\\rbl blah'); # 41 |
b3381831 GS |
140 | |
141 | @bar = @foo = qw(foo bar); # 42 | |
0dd3f902 NC |
142 | is("@foo", "foo bar"); |
143 | is("@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 | { | |
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 NC |
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 GS |
202 | } |
203 | ||
f17e6c41 RGS |
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 NC |
228 | my $t = curr_test(); |
229 | sub reify { $_[1] = $t++; print "@_\n"; } | |
352edd90 GS |
230 | reify('ok'); |
231 | reify('ok'); | |
9d001be8 | 232 | |
0dd3f902 | 233 | curr_test($t); |
7517970f | 234 | |
0dd3f902 NC |
235 | # qw() is no longer a runtime split, it's compiletime. |
236 | is (qw(foo bar snorfle)[2], 'snorfle'); | |
7517970f | 237 | |
0dd3f902 | 238 | @ary = (12,23,34,45,56); |
7517970f | 239 | |
0dd3f902 NC |
240 | is(shift(@ary), 12); |
241 | is(pop(@ary), 56); | |
242 | is(push(@ary,56), 4); | |
243 | is(unshift(@ary,12), 5); | |
4c8f17b9 BH |
244 | |
245 | sub foo { "a" } | |
246 | @foo=(foo())[0,0]; | |
0dd3f902 | 247 | is ($foo[1], "a"); |
b0840a2a RH |
248 | |
249 | # $[ should have the same effect regardless of whether the aelem | |
250 | # op is optimized to aelemfast. | |
251 | ||
0dd3f902 NC |
252 | |
253 | ||
b0840a2a RH |
254 | sub tary { |
255 | local $[ = 10; | |
256 | my $five = 5; | |
0dd3f902 | 257 | is ($tary[5], $tary[$five]); |
b0840a2a RH |
258 | } |
259 | ||
260 | @tary = (0..50); | |
261 | tary(); | |
6b42d12b DM |
262 | |
263 | ||
6b42d12b DM |
264 | # bugid #15439 - clearing an array calls destructors which may try |
265 | # to modify the array - caused 'Attempt to free unreferenced scalar' | |
266 | ||
267 | my $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 | 277 | is ($got, ''); |
2b573ace JH |
278 | |
279 | # Test negative and funky indices. | |
280 | ||
0dd3f902 | 281 | |
2b573ace JH |
282 | { |
283 | my @a = 0..4; | |
0dd3f902 NC |
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 JH |
293 | } |
294 | ||
2b573ace JH |
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 NC |
302 | sub test_arylen { |
303 | my $ref = shift; | |
83bf042f | 304 | local $^W = 1; |
1b20cd17 | 305 | is ($$ref, undef, "\$# on freed array is undef"); |
83bf042f NC |
306 | my @warn; |
307 | local $SIG{__WARN__} = sub {push @warn, "@_"}; | |
1b20cd17 | 308 | $$ref = 1000; |
83bf042f NC |
309 | is (scalar @warn, 1); |
310 | like ($warn[0], qr/^Attempt to set length of freed array/); | |
311 | } | |
1b20cd17 NC |
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 NC |
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 NC |
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 NC |
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 RH |
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 RGS |
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"; |