Commit | Line | Data |
a687059c |
1 | #!./perl |
2 | |
6b42d12b |
3 | BEGIN { |
4 | chdir 't' if -d 't'; |
404a4710 |
5 | @INC = ('.', '../lib'); |
6b42d12b |
6 | } |
7 | |
0dd3f902 |
8 | require 'test.pl'; |
9 | |
0f907b96 |
10 | plan (127); |
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 |
17 | is(join('',@ary), '12345'); |
a687059c |
18 | |
19 | $tmp = $ary[$#ary]; --$#ary; |
0dd3f902 |
20 | is($tmp, 5); |
21 | is($#ary, 3); |
22 | is(join('',@ary), '1234'); |
a687059c |
23 | |
136c2a5e |
24 | { |
25 | no warnings 'deprecated'; |
26 | |
a687059c |
27 | $[ = 1; |
28 | @ary = (1,2,3,4,5); |
0dd3f902 |
29 | is(join('',@ary), '12345'); |
a687059c |
30 | |
31 | $tmp = $ary[$#ary]; --$#ary; |
0dd3f902 |
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 |
40 | ok($#ary == 5); |
41 | ok(!defined $ary[5]); |
a687059c |
42 | |
43 | $[ = 0; |
44 | @foo = (); |
45 | $r = join(',', $#foo, @foo); |
0dd3f902 |
46 | is($r, "-1"); |
a687059c |
47 | $foo[0] = '0'; |
48 | $r = join(',', $#foo, @foo); |
0dd3f902 |
49 | is($r, "0,0"); |
a687059c |
50 | $foo[2] = '2'; |
51 | $r = join(',', $#foo, @foo); |
0dd3f902 |
52 | is($r, "2,0,,2"); |
a687059c |
53 | @bar = (); |
54 | $bar[0] = '0'; |
55 | $bar[1] = '1'; |
56 | $r = join(',', $#bar, @bar); |
0dd3f902 |
57 | is($r, "1,0,1"); |
a687059c |
58 | @bar = (); |
59 | $r = join(',', $#bar, @bar); |
0dd3f902 |
60 | is($r, "-1"); |
a687059c |
61 | $bar[0] = '0'; |
62 | $r = join(',', $#bar, @bar); |
0dd3f902 |
63 | is($r, "0,0"); |
a687059c |
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 |
68 | @bar = (); |
69 | $bar[0] = '0'; |
70 | $r = join(',', $#bar, @bar); |
0dd3f902 |
71 | is($r, "0,0"); |
a687059c |
72 | $bar[2] = '2'; |
73 | $r = join(',', $#bar, @bar); |
0dd3f902 |
74 | is($r, "2,0,,2"); |
a687059c |
75 | |
136c2a5e |
76 | } |
77 | |
a687059c |
78 | $foo = 'now is the time'; |
0dd3f902 |
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 |
83 | |
84 | $foo = 'lskjdf'; |
0dd3f902 |
85 | ok(!($cnt = (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/)))) |
86 | or diag("$cnt $F1:$F2:$Etc"); |
a687059c |
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 |
94 | is($bar{'foo'}, 'bar'); |
95 | is($bar{'how'}, 'now'); |
a687059c |
96 | @bar{keys %foo} = values %foo; |
0dd3f902 |
97 | is($bar{'foo'}, 'bar'); |
98 | is($bar{'how'}, 'now'); |
a687059c |
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 |
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 |
105 | |
106 | $foo = join('',('a','b','c','d','e','f')[0..5]); |
0dd3f902 |
107 | is($foo, 'abcdef'); |
79a0689e |
108 | |
109 | $foo = join('',('a','b','c','d','e','f')[0..1]); |
0dd3f902 |
110 | is($foo, 'ab'); |
79a0689e |
111 | |
112 | $foo = join('',('a','b','c','d','e','f')[6]); |
0dd3f902 |
113 | is($foo, ''); |
79a0689e |
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 |
119 | |
120 | $foo = ('a','b','c','d','e','f')[0,2,4]; |
0dd3f902 |
121 | is($foo, 'e'); |
79a0689e |
122 | |
123 | $foo = ('a','b','c','d','e','f')[1]; |
0dd3f902 |
124 | is($foo, 'b'); |
a0231f0e |
125 | |
c6aa4a32 |
126 | @foo = ( 'foo', 'bar', 'burbl'); |
136c2a5e |
127 | { |
128 | no warnings 'deprecated'; |
129 | push(foo, 'blah'); |
130 | } |
0dd3f902 |
131 | is($#foo, 3); |
b3381831 |
132 | |
133 | # various AASSIGN_COMMON checks (see newASSIGNOP() in op.c) |
134 | |
0dd3f902 |
135 | #curr_test(38); |
b3381831 |
136 | |
137 | @foo = @foo; |
0dd3f902 |
138 | is("@foo", "foo bar burbl blah"); # 38 |
b3381831 |
139 | |
140 | (undef,@foo) = @foo; |
0dd3f902 |
141 | is("@foo", "bar burbl blah"); # 39 |
b3381831 |
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 |
148 | |
149 | @bar = @foo = qw(foo bar); # 42 |
0dd3f902 |
150 | is("@foo", "foo bar"); |
151 | is("@bar", "foo bar"); # 43 |
b3381831 |
152 | |
153 | # try the same with local |
05fc92f1 |
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 |
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 |
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 |
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 |
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 |
210 | } |
211 | |
f17e6c41 |
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 |
236 | my $t = curr_test(); |
237 | sub reify { $_[1] = $t++; print "@_\n"; } |
352edd90 |
238 | reify('ok'); |
239 | reify('ok'); |
9d001be8 |
240 | |
0dd3f902 |
241 | curr_test($t); |
7517970f |
242 | |
0dd3f902 |
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 |
248 | is(shift(@ary), 12); |
249 | is(pop(@ary), 56); |
250 | is(push(@ary,56), 4); |
251 | is(unshift(@ary,12), 5); |
4c8f17b9 |
252 | |
253 | sub foo { "a" } |
254 | @foo=(foo())[0,0]; |
0dd3f902 |
255 | is ($foo[1], "a"); |
b0840a2a |
256 | |
257 | # $[ should have the same effect regardless of whether the aelem |
258 | # op is optimized to aelemfast. |
259 | |
0dd3f902 |
260 | |
261 | |
b0840a2a |
262 | sub tary { |
136c2a5e |
263 | no warnings 'deprecated'; |
b0840a2a |
264 | local $[ = 10; |
265 | my $five = 5; |
0dd3f902 |
266 | is ($tary[5], $tary[$five]); |
b0840a2a |
267 | } |
268 | |
269 | @tary = (0..50); |
270 | tary(); |
6b42d12b |
271 | |
272 | |
6b42d12b |
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 |
287 | |
288 | # Test negative and funky indices. |
289 | |
0dd3f902 |
290 | |
2b573ace |
291 | { |
292 | my @a = 0..4; |
0dd3f902 |
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 |
302 | } |
303 | |
2b573ace |
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 |
311 | sub test_arylen { |
312 | my $ref = shift; |
83bf042f |
313 | local $^W = 1; |
1b20cd17 |
314 | is ($$ref, undef, "\$# on freed array is undef"); |
83bf042f |
315 | my @warn; |
316 | local $SIG{__WARN__} = sub {push @warn, "@_"}; |
1b20cd17 |
317 | $$ref = 1000; |
83bf042f |
318 | is (scalar @warn, 1); |
319 | like ($warn[0], qr/^Attempt to set length of freed array/); |
320 | } |
1b20cd17 |
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 |
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 |
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 |
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 |
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 |
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 | |
0f907b96 |
431 | # [perl #70171] |
432 | { |
433 | my $x = get_x(); my %x = %$x; sub get_x { %x=(1..4); return \%x }; |
434 | is( |
435 | join(" ", map +($_,$x{$_}), sort keys %x), "1 2 3 4", |
436 | 'bug 70171 (self-assignment via my %x = %$x)' |
437 | ); |
438 | my $y = get_y(); my @y = @$y; sub get_y { @y=(1..4); return \@y }; |
439 | is( |
440 | "@y", "1 2 3 4", |
441 | 'bug 70171 (self-assignment via my @x = @$x)' |
442 | ); |
443 | } |
444 | |
f17e6c41 |
445 | |
404a4710 |
446 | "We're included by lib/Tie/Array/std.t so we need to return something true"; |