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