Commit | Line | Data |
---|---|---|
a687059c LW |
1 | #!./perl |
2 | ||
6b42d12b DM |
3 | BEGIN { |
4 | chdir 't' if -d 't'; | |
404a4710 | 5 | @INC = ('.', '../lib'); |
9f71cfe6 | 6 | require 'test.pl'; |
6b42d12b DM |
7 | } |
8 | ||
428ccf1e | 9 | plan (137); |
a687059c | 10 | |
05fc92f1 GS |
11 | # |
12 | # @foo, @bar, and @ary are also used from tie-stdarray after tie-ing them | |
13 | # | |
14 | ||
a687059c | 15 | @ary = (1,2,3,4,5); |
0dd3f902 | 16 | is(join('',@ary), '12345'); |
a687059c LW |
17 | |
18 | $tmp = $ary[$#ary]; --$#ary; | |
0dd3f902 NC |
19 | is($tmp, 5); |
20 | is($#ary, 3); | |
21 | is(join('',@ary), '1234'); | |
a687059c | 22 | |
a687059c LW |
23 | @foo = (); |
24 | $r = join(',', $#foo, @foo); | |
0dd3f902 | 25 | is($r, "-1"); |
a687059c LW |
26 | $foo[0] = '0'; |
27 | $r = join(',', $#foo, @foo); | |
0dd3f902 | 28 | is($r, "0,0"); |
a687059c LW |
29 | $foo[2] = '2'; |
30 | $r = join(',', $#foo, @foo); | |
0dd3f902 | 31 | is($r, "2,0,,2"); |
a687059c LW |
32 | @bar = (); |
33 | $bar[0] = '0'; | |
34 | $bar[1] = '1'; | |
35 | $r = join(',', $#bar, @bar); | |
0dd3f902 | 36 | is($r, "1,0,1"); |
a687059c LW |
37 | @bar = (); |
38 | $r = join(',', $#bar, @bar); | |
0dd3f902 | 39 | is($r, "-1"); |
a687059c LW |
40 | $bar[0] = '0'; |
41 | $r = join(',', $#bar, @bar); | |
0dd3f902 | 42 | is($r, "0,0"); |
a687059c LW |
43 | $bar[2] = '2'; |
44 | $r = join(',', $#bar, @bar); | |
0dd3f902 | 45 | is($r, "2,0,,2"); |
14ce8c55 | 46 | reset 'b' if $^O ne 'VMS'; |
a687059c LW |
47 | @bar = (); |
48 | $bar[0] = '0'; | |
49 | $r = join(',', $#bar, @bar); | |
0dd3f902 | 50 | is($r, "0,0"); |
a687059c LW |
51 | $bar[2] = '2'; |
52 | $r = join(',', $#bar, @bar); | |
0dd3f902 | 53 | is($r, "2,0,,2"); |
a687059c LW |
54 | |
55 | $foo = 'now is the time'; | |
0dd3f902 NC |
56 | ok(scalar (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/))); |
57 | is($F1, 'now'); | |
58 | is($F2, 'is'); | |
59 | is($Etc, 'the time'); | |
a687059c LW |
60 | |
61 | $foo = 'lskjdf'; | |
0dd3f902 NC |
62 | ok(!($cnt = (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/)))) |
63 | or diag("$cnt $F1:$F2:$Etc"); | |
a687059c LW |
64 | |
65 | %foo = ('blurfl','dyick','foo','bar','etc.','etc.'); | |
66 | %bar = %foo; | |
0dd3f902 | 67 | is($bar{'foo'}, 'bar'); |
a687059c | 68 | %bar = (); |
0dd3f902 | 69 | is($bar{'foo'}, undef); |
a687059c | 70 | (%bar,$a,$b) = (%foo,'how','now'); |
0dd3f902 NC |
71 | is($bar{'foo'}, 'bar'); |
72 | is($bar{'how'}, 'now'); | |
a687059c | 73 | @bar{keys %foo} = values %foo; |
0dd3f902 NC |
74 | is($bar{'foo'}, 'bar'); |
75 | is($bar{'how'}, 'now'); | |
a687059c LW |
76 | |
77 | @foo = grep(/e/,split(' ','now is the time for all good men to come to')); | |
0dd3f902 | 78 | is(join(' ',@foo), 'the time men come'); |
a687059c LW |
79 | |
80 | @foo = grep(!/e/,split(' ','now is the time for all good men to come to')); | |
0dd3f902 | 81 | is(join(' ',@foo), 'now is for all good to to'); |
79a0689e LW |
82 | |
83 | $foo = join('',('a','b','c','d','e','f')[0..5]); | |
0dd3f902 | 84 | is($foo, 'abcdef'); |
79a0689e LW |
85 | |
86 | $foo = join('',('a','b','c','d','e','f')[0..1]); | |
0dd3f902 | 87 | is($foo, 'ab'); |
79a0689e LW |
88 | |
89 | $foo = join('',('a','b','c','d','e','f')[6]); | |
0dd3f902 | 90 | is($foo, ''); |
79a0689e LW |
91 | |
92 | @foo = ('a','b','c','d','e','f')[0,2,4]; | |
93 | @bar = ('a','b','c','d','e','f')[1,3,5]; | |
94 | $foo = join('',(@foo,@bar)[0..5]); | |
0dd3f902 | 95 | is($foo, 'acebdf'); |
79a0689e LW |
96 | |
97 | $foo = ('a','b','c','d','e','f')[0,2,4]; | |
0dd3f902 | 98 | is($foo, 'e'); |
79a0689e LW |
99 | |
100 | $foo = ('a','b','c','d','e','f')[1]; | |
0dd3f902 | 101 | is($foo, 'b'); |
a0231f0e | 102 | |
c6aa4a32 | 103 | @foo = ( 'foo', 'bar', 'burbl'); |
136c2a5e NC |
104 | { |
105 | no warnings 'deprecated'; | |
106 | push(foo, 'blah'); | |
107 | } | |
0dd3f902 | 108 | is($#foo, 3); |
b3381831 GS |
109 | |
110 | # various AASSIGN_COMMON checks (see newASSIGNOP() in op.c) | |
111 | ||
0dd3f902 | 112 | #curr_test(38); |
b3381831 GS |
113 | |
114 | @foo = @foo; | |
0dd3f902 | 115 | is("@foo", "foo bar burbl blah"); # 38 |
b3381831 GS |
116 | |
117 | (undef,@foo) = @foo; | |
0dd3f902 | 118 | is("@foo", "bar burbl blah"); # 39 |
b3381831 GS |
119 | |
120 | @foo = ('XXX',@foo, 'YYY'); | |
0dd3f902 | 121 | is("@foo", "XXX bar burbl blah YYY"); # 40 |
b3381831 | 122 | |
3201ebbd | 123 | @foo = @foo = qw(foo b\a\r bu\\rbl blah); |
0dd3f902 | 124 | is("@foo", 'foo b\a\r bu\\rbl blah'); # 41 |
b3381831 GS |
125 | |
126 | @bar = @foo = qw(foo bar); # 42 | |
0dd3f902 NC |
127 | is("@foo", "foo bar"); |
128 | is("@bar", "foo bar"); # 43 | |
b3381831 GS |
129 | |
130 | # try the same with local | |
05fc92f1 GS |
131 | # XXX tie-stdarray fails the tests involving local, so we use |
132 | # different variable names to escape the 'tie' | |
133 | ||
134 | @bee = ( 'foo', 'bar', 'burbl', 'blah'); | |
b3381831 GS |
135 | { |
136 | ||
05fc92f1 | 137 | local @bee = @bee; |
0dd3f902 | 138 | is("@bee", "foo bar burbl blah"); # 44 |
b3381831 | 139 | { |
05fc92f1 | 140 | local (undef,@bee) = @bee; |
0dd3f902 | 141 | is("@bee", "bar burbl blah"); # 45 |
b3381831 | 142 | { |
05fc92f1 | 143 | local @bee = ('XXX',@bee,'YYY'); |
0dd3f902 | 144 | is("@bee", "XXX bar burbl blah YYY"); # 46 |
b3381831 | 145 | { |
05fc92f1 | 146 | local @bee = local(@bee) = qw(foo bar burbl blah); |
0dd3f902 | 147 | is("@bee", "foo bar burbl blah"); # 47 |
b3381831 | 148 | { |
05fc92f1 | 149 | local (@bim) = local(@bee) = qw(foo bar); |
0dd3f902 NC |
150 | is("@bee", "foo bar"); # 48 |
151 | is("@bim", "foo bar"); # 49 | |
b3381831 | 152 | } |
0dd3f902 | 153 | is("@bee", "foo bar burbl blah"); # 50 |
b3381831 | 154 | } |
0dd3f902 | 155 | is("@bee", "XXX bar burbl blah YYY"); # 51 |
b3381831 | 156 | } |
0dd3f902 | 157 | is("@bee", "bar burbl blah"); # 52 |
b3381831 | 158 | } |
0dd3f902 | 159 | is("@bee", "foo bar burbl blah"); # 53 |
b3381831 GS |
160 | } |
161 | ||
162 | # try the same with my | |
163 | { | |
05fc92f1 | 164 | my @bee = @bee; |
0dd3f902 | 165 | is("@bee", "foo bar burbl blah"); # 54 |
b3381831 | 166 | { |
05fc92f1 | 167 | my (undef,@bee) = @bee; |
0dd3f902 | 168 | is("@bee", "bar burbl blah"); # 55 |
b3381831 | 169 | { |
05fc92f1 | 170 | my @bee = ('XXX',@bee,'YYY'); |
0dd3f902 | 171 | is("@bee", "XXX bar burbl blah YYY"); # 56 |
b3381831 | 172 | { |
05fc92f1 | 173 | my @bee = my @bee = qw(foo bar burbl blah); |
0dd3f902 | 174 | is("@bee", "foo bar burbl blah"); # 57 |
b3381831 | 175 | { |
05fc92f1 | 176 | my (@bim) = my(@bee) = qw(foo bar); |
0dd3f902 NC |
177 | is("@bee", "foo bar"); # 58 |
178 | is("@bim", "foo bar"); # 59 | |
b3381831 | 179 | } |
0dd3f902 | 180 | is("@bee", "foo bar burbl blah"); # 60 |
b3381831 | 181 | } |
0dd3f902 | 182 | is("@bee", "XXX bar burbl blah YYY"); # 61 |
b3381831 | 183 | } |
0dd3f902 | 184 | is("@bee", "bar burbl blah"); # 62 |
b3381831 | 185 | } |
0dd3f902 | 186 | is("@bee", "foo bar burbl blah"); # 63 |
b3381831 GS |
187 | } |
188 | ||
f17e6c41 RGS |
189 | # try the same with our (except that previous values aren't restored) |
190 | { | |
191 | our @bee = @bee; | |
192 | is("@bee", "foo bar burbl blah"); | |
193 | { | |
194 | our (undef,@bee) = @bee; | |
195 | is("@bee", "bar burbl blah"); | |
196 | { | |
197 | our @bee = ('XXX',@bee,'YYY'); | |
198 | is("@bee", "XXX bar burbl blah YYY"); | |
199 | { | |
200 | our @bee = our @bee = qw(foo bar burbl blah); | |
201 | is("@bee", "foo bar burbl blah"); | |
202 | { | |
203 | our (@bim) = our(@bee) = qw(foo bar); | |
204 | is("@bee", "foo bar"); | |
205 | is("@bim", "foo bar"); | |
206 | } | |
207 | } | |
208 | } | |
209 | } | |
210 | } | |
211 | ||
352edd90 | 212 | # make sure reification behaves |
0dd3f902 NC |
213 | my $t = curr_test(); |
214 | sub reify { $_[1] = $t++; print "@_\n"; } | |
352edd90 GS |
215 | reify('ok'); |
216 | reify('ok'); | |
9d001be8 | 217 | |
0dd3f902 | 218 | curr_test($t); |
7517970f | 219 | |
0dd3f902 NC |
220 | # qw() is no longer a runtime split, it's compiletime. |
221 | is (qw(foo bar snorfle)[2], 'snorfle'); | |
7517970f | 222 | |
0dd3f902 | 223 | @ary = (12,23,34,45,56); |
7517970f | 224 | |
0dd3f902 NC |
225 | is(shift(@ary), 12); |
226 | is(pop(@ary), 56); | |
227 | is(push(@ary,56), 4); | |
228 | is(unshift(@ary,12), 5); | |
4c8f17b9 BH |
229 | |
230 | sub foo { "a" } | |
231 | @foo=(foo())[0,0]; | |
0dd3f902 | 232 | is ($foo[1], "a"); |
b0840a2a | 233 | |
6b42d12b DM |
234 | # bugid #15439 - clearing an array calls destructors which may try |
235 | # to modify the array - caused 'Attempt to free unreferenced scalar' | |
236 | ||
237 | my $got = runperl ( | |
238 | prog => q{ | |
239 | sub X::DESTROY { @a = () } | |
3d7a9343 | 240 | @a = (bless {}, q{X}); |
6b42d12b DM |
241 | @a = (); |
242 | }, | |
243 | stderr => 1 | |
244 | ); | |
245 | ||
246 | $got =~ s/\n/ /g; | |
0dd3f902 | 247 | is ($got, ''); |
2b573ace JH |
248 | |
249 | # Test negative and funky indices. | |
250 | ||
0dd3f902 | 251 | |
2b573ace JH |
252 | { |
253 | my @a = 0..4; | |
0dd3f902 NC |
254 | is($a[-1], 4); |
255 | is($a[-2], 3); | |
256 | is($a[-5], 0); | |
257 | ok(!defined $a[-6]); | |
258 | ||
259 | is($a[2.1] , 2); | |
260 | is($a[2.9] , 2); | |
261 | is($a[undef], 0); | |
262 | is($a["3rd"], 3); | |
2b573ace JH |
263 | } |
264 | ||
2b573ace JH |
265 | |
266 | { | |
267 | my @a; | |
268 | eval '$a[-1] = 0'; | |
0dd3f902 | 269 | like($@, qr/Modification of non-creatable array value attempted, subscript -1/, "\$a[-1] = 0"); |
2b573ace | 270 | } |
0dd3f902 | 271 | |
1b20cd17 NC |
272 | sub test_arylen { |
273 | my $ref = shift; | |
83bf042f | 274 | local $^W = 1; |
1b20cd17 | 275 | is ($$ref, undef, "\$# on freed array is undef"); |
83bf042f NC |
276 | my @warn; |
277 | local $SIG{__WARN__} = sub {push @warn, "@_"}; | |
1b20cd17 | 278 | $$ref = 1000; |
83bf042f NC |
279 | is (scalar @warn, 1); |
280 | like ($warn[0], qr/^Attempt to set length of freed array/); | |
281 | } | |
1b20cd17 NC |
282 | |
283 | { | |
284 | my $a = \$#{[]}; | |
285 | # Need a new statement to make it go out of scope | |
286 | test_arylen ($a); | |
287 | test_arylen (do {my @a; \$#a}); | |
288 | } | |
404a4710 NC |
289 | |
290 | { | |
291 | use vars '@array'; | |
292 | ||
293 | my $outer = \$#array; | |
294 | is ($$outer, -1); | |
295 | is (scalar @array, 0); | |
296 | ||
297 | $$outer = 3; | |
298 | is ($$outer, 3); | |
299 | is (scalar @array, 4); | |
300 | ||
301 | my $ref = \@array; | |
302 | ||
404a4710 NC |
303 | my $inner; |
304 | { | |
305 | local @array; | |
306 | $inner = \$#array; | |
307 | ||
308 | is ($$inner, -1); | |
309 | is (scalar @array, 0); | |
310 | $$outer = 6; | |
311 | ||
312 | is (scalar @$ref, 7); | |
313 | ||
314 | is ($$inner, -1); | |
315 | is (scalar @array, 0); | |
316 | ||
317 | $$inner = 42; | |
318 | } | |
319 | ||
320 | is (scalar @array, 7); | |
321 | is ($$outer, 6); | |
322 | ||
2fc04a10 | 323 | is ($$inner, undef, "orphaned $#foo is always undef"); |
404a4710 NC |
324 | |
325 | is (scalar @array, 7); | |
326 | is ($$outer, 6); | |
327 | ||
328 | $$inner = 1; | |
329 | ||
330 | is (scalar @array, 7); | |
331 | is ($$outer, 6); | |
332 | ||
333 | $$inner = 503; # Bang! | |
334 | ||
335 | is (scalar @array, 7); | |
336 | is ($$outer, 6); | |
337 | } | |
338 | ||
339 | { | |
340 | # Bug #36211 | |
341 | use vars '@array'; | |
342 | for (1,2) { | |
343 | { | |
344 | local @a; | |
345 | is ($#a, -1); | |
346 | @a=(1..4) | |
347 | } | |
348 | } | |
349 | } | |
350 | ||
e4c5ccf3 RH |
351 | { |
352 | # Bug #37350 | |
353 | my @array = (1..4); | |
354 | $#{@array} = 7; | |
355 | is ($#{4}, 7); | |
356 | ||
357 | my $x; | |
358 | $#{$x} = 3; | |
359 | is(scalar @$x, 4); | |
360 | ||
361 | push @{@array}, 23; | |
362 | is ($4[8], 23); | |
363 | } | |
364 | { | |
365 | # Bug #37350 -- once more with a global | |
366 | use vars '@array'; | |
367 | @array = (1..4); | |
368 | $#{@array} = 7; | |
369 | is ($#{4}, 7); | |
370 | ||
371 | my $x; | |
372 | $#{$x} = 3; | |
373 | is(scalar @$x, 4); | |
374 | ||
375 | push @{@array}, 23; | |
376 | is ($4[8], 23); | |
377 | } | |
378 | ||
f17e6c41 RGS |
379 | # more tests for AASSIGN_COMMON |
380 | ||
381 | { | |
382 | our($x,$y,$z) = (1..3); | |
383 | our($y,$z) = ($x,$y); | |
384 | is("$x $y $z", "1 1 2"); | |
385 | } | |
386 | { | |
387 | our($x,$y,$z) = (1..3); | |
388 | (our $y, our $z) = ($x,$y); | |
389 | is("$x $y $z", "1 1 2"); | |
390 | } | |
8d38d4f3 | 391 | { |
3023b5f3 | 392 | # AASSIGN_COMMON detection with logical operators |
8d38d4f3 GG |
393 | my $true = 1; |
394 | our($x,$y,$z) = (1..3); | |
395 | (our $y, our $z) = $true && ($x,$y); | |
396 | is("$x $y $z", "1 1 2"); | |
397 | } | |
f17e6c41 | 398 | |
0f907b96 FC |
399 | # [perl #70171] |
400 | { | |
401 | my $x = get_x(); my %x = %$x; sub get_x { %x=(1..4); return \%x }; | |
402 | is( | |
403 | join(" ", map +($_,$x{$_}), sort keys %x), "1 2 3 4", | |
404 | 'bug 70171 (self-assignment via my %x = %$x)' | |
405 | ); | |
406 | my $y = get_y(); my @y = @$y; sub get_y { @y=(1..4); return \@y }; | |
407 | is( | |
408 | "@y", "1 2 3 4", | |
409 | 'bug 70171 (self-assignment via my @x = @$x)' | |
410 | ); | |
411 | } | |
412 | ||
ade1ceae DM |
413 | # [perl #70171], [perl #82110] |
414 | { | |
415 | my ($i, $ra, $rh); | |
416 | again: | |
417 | my @a = @$ra; # common assignment on 2nd attempt | |
418 | my %h = %$rh; # common assignment on 2nd attempt | |
419 | @a = qw(1 2 3 4); | |
420 | %h = qw(a 1 b 2 c 3 d 4); | |
421 | $ra = \@a; | |
422 | $rh = \%h; | |
423 | goto again unless $i++; | |
424 | ||
425 | is("@a", "1 2 3 4", | |
426 | 'bug 70171 (self-assignment via my @x = @$x) - goto variant' | |
427 | ); | |
428 | is( | |
429 | join(" ", map +($_,$h{$_}), sort keys %h), "a 1 b 2 c 3 d 4", | |
430 | 'bug 70171 (self-assignment via my %x = %$x) - goto variant' | |
431 | ); | |
432 | } | |
433 | ||
434 | ||
8f878375 FC |
435 | *trit = *scile; $trit[0]; |
436 | ok(1, 'aelem_fast on a nonexistent array does not crash'); | |
f17e6c41 | 437 | |
9f71cfe6 FC |
438 | # [perl #107440] |
439 | sub A::DESTROY { $::ra = 0 } | |
440 | $::ra = [ bless [], 'A' ]; | |
441 | undef @$::ra; | |
442 | pass 'no crash when freeing array that is being undeffed'; | |
443 | $::ra = [ bless [], 'A' ]; | |
444 | @$::ra = ('a'..'z'); | |
445 | pass 'no crash when freeing array that is being cleared'; | |
446 | ||
70ce9249 FC |
447 | # [perl #85670] Copying magic to elements |
448 | SKIP: { | |
449 | skip "no Scalar::Util::weaken on miniperl", 1, if is_miniperl; | |
450 | require Scalar::Util; | |
451 | package glelp { | |
452 | Scalar::Util::weaken ($a = \@ISA); | |
453 | @ISA = qw(Foo); | |
454 | Scalar::Util::weaken ($a = \$ISA[0]); | |
455 | ::is @ISA, 1, 'backref magic is not copied to elements'; | |
456 | } | |
457 | } | |
458 | package peen { | |
459 | $#ISA = -1; | |
460 | @ISA = qw(Foo); | |
461 | $ISA[0] = qw(Sphare); | |
462 | ||
463 | sub Sphare::pling { 'pling' } | |
464 | ||
465 | ::is eval { pling peen }, 'pling', | |
466 | 'arylen_p magic does not stop isa magic from being copied'; | |
467 | } | |
468 | ||
97568419 FC |
469 | # Test that &PL_sv_undef is not special in arrays |
470 | sub { | |
471 | ok exists $_[0], | |
472 | 'exists returns true for &PL_sv_undef elem [perl #7508]'; | |
473 | is \$_[0], \undef, 'undef preserves identity in array [perl #109726]'; | |
474 | }->(undef); | |
428ccf1e FC |
475 | # and that padav also knows how to handle the resulting NULLs |
476 | @_ = sub { my @a; $a[1]=1; @a }->(); | |
477 | is join (" ", map $_//"undef", @_), "undef 1", | |
478 | 'returning my @a with nonexistent elements'; | |
97568419 | 479 | |
bbfdc870 FC |
480 | # [perl #118691] |
481 | @plink=@plunk=(); | |
482 | $plink[3] = 1; | |
483 | sub { | |
484 | $_[0] = 2; | |
485 | is $plink[0], 2, '@_ alias to nonexistent elem within array'; | |
486 | $_[1] = 3; | |
487 | is $plink[1], 3, '@_ alias to nonexistent neg index within array'; | |
488 | is $_[2], undef, 'reading alias to negative index past beginning'; | |
489 | eval { $_[2] = 42 }; | |
490 | like $@, qr/Modification of non-creatable array value attempted, (?x: | |
491 | )subscript -5/, | |
492 | 'error when setting alias to negative index past beginning'; | |
493 | is $_[3], undef, 'reading alias to -1 elem of empty array'; | |
494 | eval { $_[3] = 42 }; | |
495 | like $@, qr/Modification of non-creatable array value attempted, (?x: | |
496 | )subscript -1/, | |
497 | 'error when setting alias to -1 elem of empty array'; | |
498 | }->($plink[0], $plink[-2], $plink[-5], $plunk[-1]); | |
499 | ||
d4a823b3 FC |
500 | $_ = \$#{[]}; |
501 | $$_ = \1; | |
502 | "$$_"; | |
503 | pass "no assertion failure after assigning ref to arylen when ary is gone"; | |
70ce9249 | 504 | |
404a4710 | 505 | "We're included by lib/Tie/Array/std.t so we need to return something true"; |