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 | 23 | |
136c2a5e NC |
24 | { |
25 | no warnings 'deprecated'; | |
26 | ||
a687059c LW |
27 | $[ = 1; |
28 | @ary = (1,2,3,4,5); | |
0dd3f902 | 29 | is(join('',@ary), '12345'); |
a687059c LW |
30 | |
31 | $tmp = $ary[$#ary]; --$#ary; | |
0dd3f902 NC |
32 | is($tmp, 5); |
33 | # Must do == here beacuse $[ isn't 0 | |
34 | ok($#ary == 4); | |
35 | is(join('',@ary), '1234'); | |
a687059c | 36 | |
0dd3f902 | 37 | is($ary[5], undef); |
a687059c | 38 | |
a0d0e21e | 39 | $#ary += 1; # see if element 5 gone for good |
0dd3f902 NC |
40 | ok($#ary == 5); |
41 | ok(!defined $ary[5]); | |
a687059c LW |
42 | |
43 | $[ = 0; | |
44 | @foo = (); | |
45 | $r = join(',', $#foo, @foo); | |
0dd3f902 | 46 | is($r, "-1"); |
a687059c LW |
47 | $foo[0] = '0'; |
48 | $r = join(',', $#foo, @foo); | |
0dd3f902 | 49 | is($r, "0,0"); |
a687059c LW |
50 | $foo[2] = '2'; |
51 | $r = join(',', $#foo, @foo); | |
0dd3f902 | 52 | is($r, "2,0,,2"); |
a687059c LW |
53 | @bar = (); |
54 | $bar[0] = '0'; | |
55 | $bar[1] = '1'; | |
56 | $r = join(',', $#bar, @bar); | |
0dd3f902 | 57 | is($r, "1,0,1"); |
a687059c LW |
58 | @bar = (); |
59 | $r = join(',', $#bar, @bar); | |
0dd3f902 | 60 | is($r, "-1"); |
a687059c LW |
61 | $bar[0] = '0'; |
62 | $r = join(',', $#bar, @bar); | |
0dd3f902 | 63 | is($r, "0,0"); |
a687059c LW |
64 | $bar[2] = '2'; |
65 | $r = join(',', $#bar, @bar); | |
0dd3f902 | 66 | is($r, "2,0,,2"); |
14ce8c55 | 67 | reset 'b' if $^O ne 'VMS'; |
a687059c LW |
68 | @bar = (); |
69 | $bar[0] = '0'; | |
70 | $r = join(',', $#bar, @bar); | |
0dd3f902 | 71 | is($r, "0,0"); |
a687059c LW |
72 | $bar[2] = '2'; |
73 | $r = join(',', $#bar, @bar); | |
0dd3f902 | 74 | is($r, "2,0,,2"); |
a687059c | 75 | |
136c2a5e NC |
76 | } |
77 | ||
a687059c | 78 | $foo = 'now is the time'; |
0dd3f902 NC |
79 | ok(scalar (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/))); |
80 | is($F1, 'now'); | |
81 | is($F2, 'is'); | |
82 | is($Etc, 'the time'); | |
a687059c LW |
83 | |
84 | $foo = 'lskjdf'; | |
0dd3f902 NC |
85 | ok(!($cnt = (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/)))) |
86 | or diag("$cnt $F1:$F2:$Etc"); | |
a687059c LW |
87 | |
88 | %foo = ('blurfl','dyick','foo','bar','etc.','etc.'); | |
89 | %bar = %foo; | |
0dd3f902 | 90 | is($bar{'foo'}, 'bar'); |
a687059c | 91 | %bar = (); |
0dd3f902 | 92 | is($bar{'foo'}, undef); |
a687059c | 93 | (%bar,$a,$b) = (%foo,'how','now'); |
0dd3f902 NC |
94 | is($bar{'foo'}, 'bar'); |
95 | is($bar{'how'}, 'now'); | |
a687059c | 96 | @bar{keys %foo} = values %foo; |
0dd3f902 NC |
97 | is($bar{'foo'}, 'bar'); |
98 | is($bar{'how'}, 'now'); | |
a687059c LW |
99 | |
100 | @foo = grep(/e/,split(' ','now is the time for all good men to come to')); | |
0dd3f902 | 101 | is(join(' ',@foo), 'the time men come'); |
a687059c LW |
102 | |
103 | @foo = grep(!/e/,split(' ','now is the time for all good men to come to')); | |
0dd3f902 | 104 | is(join(' ',@foo), 'now is for all good to to'); |
79a0689e LW |
105 | |
106 | $foo = join('',('a','b','c','d','e','f')[0..5]); | |
0dd3f902 | 107 | is($foo, 'abcdef'); |
79a0689e LW |
108 | |
109 | $foo = join('',('a','b','c','d','e','f')[0..1]); | |
0dd3f902 | 110 | is($foo, 'ab'); |
79a0689e LW |
111 | |
112 | $foo = join('',('a','b','c','d','e','f')[6]); | |
0dd3f902 | 113 | is($foo, ''); |
79a0689e LW |
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]); | |
0dd3f902 | 118 | is($foo, 'acebdf'); |
79a0689e LW |
119 | |
120 | $foo = ('a','b','c','d','e','f')[0,2,4]; | |
0dd3f902 | 121 | is($foo, 'e'); |
79a0689e LW |
122 | |
123 | $foo = ('a','b','c','d','e','f')[1]; | |
0dd3f902 | 124 | is($foo, 'b'); |
a0231f0e | 125 | |
c6aa4a32 | 126 | @foo = ( 'foo', 'bar', 'burbl'); |
136c2a5e NC |
127 | { |
128 | no warnings 'deprecated'; | |
129 | push(foo, 'blah'); | |
130 | } | |
0dd3f902 | 131 | is($#foo, 3); |
b3381831 GS |
132 | |
133 | # various AASSIGN_COMMON checks (see newASSIGNOP() in op.c) | |
134 | ||
0dd3f902 | 135 | #curr_test(38); |
b3381831 GS |
136 | |
137 | @foo = @foo; | |
0dd3f902 | 138 | is("@foo", "foo bar burbl blah"); # 38 |
b3381831 GS |
139 | |
140 | (undef,@foo) = @foo; | |
0dd3f902 | 141 | is("@foo", "bar burbl blah"); # 39 |
b3381831 GS |
142 | |
143 | @foo = ('XXX',@foo, 'YYY'); | |
0dd3f902 | 144 | is("@foo", "XXX bar burbl blah YYY"); # 40 |
b3381831 | 145 | |
3201ebbd | 146 | @foo = @foo = qw(foo b\a\r bu\\rbl blah); |
0dd3f902 | 147 | is("@foo", 'foo b\a\r bu\\rbl blah'); # 41 |
b3381831 GS |
148 | |
149 | @bar = @foo = qw(foo bar); # 42 | |
0dd3f902 NC |
150 | is("@foo", "foo bar"); |
151 | is("@bar", "foo bar"); # 43 | |
b3381831 GS |
152 | |
153 | # try the same with local | |
05fc92f1 GS |
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'); | |
b3381831 GS |
158 | { |
159 | ||
05fc92f1 | 160 | local @bee = @bee; |
0dd3f902 | 161 | is("@bee", "foo bar burbl blah"); # 44 |
b3381831 | 162 | { |
05fc92f1 | 163 | local (undef,@bee) = @bee; |
0dd3f902 | 164 | is("@bee", "bar burbl blah"); # 45 |
b3381831 | 165 | { |
05fc92f1 | 166 | local @bee = ('XXX',@bee,'YYY'); |
0dd3f902 | 167 | is("@bee", "XXX bar burbl blah YYY"); # 46 |
b3381831 | 168 | { |
05fc92f1 | 169 | local @bee = local(@bee) = qw(foo bar burbl blah); |
0dd3f902 | 170 | is("@bee", "foo bar burbl blah"); # 47 |
b3381831 | 171 | { |
05fc92f1 | 172 | local (@bim) = local(@bee) = qw(foo bar); |
0dd3f902 NC |
173 | is("@bee", "foo bar"); # 48 |
174 | is("@bim", "foo bar"); # 49 | |
b3381831 | 175 | } |
0dd3f902 | 176 | is("@bee", "foo bar burbl blah"); # 50 |
b3381831 | 177 | } |
0dd3f902 | 178 | is("@bee", "XXX bar burbl blah YYY"); # 51 |
b3381831 | 179 | } |
0dd3f902 | 180 | is("@bee", "bar burbl blah"); # 52 |
b3381831 | 181 | } |
0dd3f902 | 182 | is("@bee", "foo bar burbl blah"); # 53 |
b3381831 GS |
183 | } |
184 | ||
185 | # try the same with my | |
186 | { | |
05fc92f1 | 187 | my @bee = @bee; |
0dd3f902 | 188 | is("@bee", "foo bar burbl blah"); # 54 |
b3381831 | 189 | { |
05fc92f1 | 190 | my (undef,@bee) = @bee; |
0dd3f902 | 191 | is("@bee", "bar burbl blah"); # 55 |
b3381831 | 192 | { |
05fc92f1 | 193 | my @bee = ('XXX',@bee,'YYY'); |
0dd3f902 | 194 | is("@bee", "XXX bar burbl blah YYY"); # 56 |
b3381831 | 195 | { |
05fc92f1 | 196 | my @bee = my @bee = qw(foo bar burbl blah); |
0dd3f902 | 197 | is("@bee", "foo bar burbl blah"); # 57 |
b3381831 | 198 | { |
05fc92f1 | 199 | my (@bim) = my(@bee) = qw(foo bar); |
0dd3f902 NC |
200 | is("@bee", "foo bar"); # 58 |
201 | is("@bim", "foo bar"); # 59 | |
b3381831 | 202 | } |
0dd3f902 | 203 | is("@bee", "foo bar burbl blah"); # 60 |
b3381831 | 204 | } |
0dd3f902 | 205 | is("@bee", "XXX bar burbl blah YYY"); # 61 |
b3381831 | 206 | } |
0dd3f902 | 207 | is("@bee", "bar burbl blah"); # 62 |
b3381831 | 208 | } |
0dd3f902 | 209 | is("@bee", "foo bar burbl blah"); # 63 |
b3381831 GS |
210 | } |
211 | ||
f17e6c41 RGS |
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 | ||
352edd90 | 235 | # make sure reification behaves |
0dd3f902 NC |
236 | my $t = curr_test(); |
237 | sub reify { $_[1] = $t++; print "@_\n"; } | |
352edd90 GS |
238 | reify('ok'); |
239 | reify('ok'); | |
9d001be8 | 240 | |
0dd3f902 | 241 | curr_test($t); |
7517970f | 242 | |
0dd3f902 NC |
243 | # qw() is no longer a runtime split, it's compiletime. |
244 | is (qw(foo bar snorfle)[2], 'snorfle'); | |
7517970f | 245 | |
0dd3f902 | 246 | @ary = (12,23,34,45,56); |
7517970f | 247 | |
0dd3f902 NC |
248 | is(shift(@ary), 12); |
249 | is(pop(@ary), 56); | |
250 | is(push(@ary,56), 4); | |
251 | is(unshift(@ary,12), 5); | |
4c8f17b9 BH |
252 | |
253 | sub foo { "a" } | |
254 | @foo=(foo())[0,0]; | |
0dd3f902 | 255 | is ($foo[1], "a"); |
b0840a2a RH |
256 | |
257 | # $[ should have the same effect regardless of whether the aelem | |
258 | # op is optimized to aelemfast. | |
259 | ||
0dd3f902 NC |
260 | |
261 | ||
b0840a2a | 262 | sub tary { |
136c2a5e | 263 | no warnings 'deprecated'; |
b0840a2a RH |
264 | local $[ = 10; |
265 | my $five = 5; | |
0dd3f902 | 266 | is ($tary[5], $tary[$five]); |
b0840a2a RH |
267 | } |
268 | ||
269 | @tary = (0..50); | |
270 | tary(); | |
6b42d12b DM |
271 | |
272 | ||
6b42d12b DM |
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 {}, 'X'); | |
280 | @a = (); | |
281 | }, | |
282 | stderr => 1 | |
283 | ); | |
284 | ||
285 | $got =~ s/\n/ /g; | |
0dd3f902 | 286 | is ($got, ''); |
2b573ace JH |
287 | |
288 | # Test negative and funky indices. | |
289 | ||
0dd3f902 | 290 | |
2b573ace JH |
291 | { |
292 | my @a = 0..4; | |
0dd3f902 NC |
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); | |
2b573ace JH |
302 | } |
303 | ||
2b573ace JH |
304 | |
305 | { | |
306 | my @a; | |
307 | eval '$a[-1] = 0'; | |
0dd3f902 | 308 | like($@, qr/Modification of non-creatable array value attempted, subscript -1/, "\$a[-1] = 0"); |
2b573ace | 309 | } |
0dd3f902 | 310 | |
1b20cd17 NC |
311 | sub test_arylen { |
312 | my $ref = shift; | |
83bf042f | 313 | local $^W = 1; |
1b20cd17 | 314 | is ($$ref, undef, "\$# on freed array is undef"); |
83bf042f NC |
315 | my @warn; |
316 | local $SIG{__WARN__} = sub {push @warn, "@_"}; | |
1b20cd17 | 317 | $$ref = 1000; |
83bf042f NC |
318 | is (scalar @warn, 1); |
319 | like ($warn[0], qr/^Attempt to set length of freed array/); | |
320 | } | |
1b20cd17 NC |
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 | } | |
404a4710 NC |
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 | ||
404a4710 NC |
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 | ||
2fc04a10 | 362 | is ($$inner, undef, "orphaned $#foo is always undef"); |
404a4710 NC |
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 | ||
e4c5ccf3 RH |
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 | ||
f17e6c41 RGS |
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 | ||
404a4710 | 432 | "We're included by lib/Tie/Array/std.t so we need to return something true"; |