5 @INC = ('.', '../lib');
12 # @foo, @bar, and @ary are also used from tie-stdarray after tie-ing them
16 is(join('',@ary), '12345');
18 $tmp = $ary[$#ary]; --$#ary;
21 is(join('',@ary), '1234');
24 $r = join(',', $#foo, @foo);
27 $r = join(',', $#foo, @foo);
30 $r = join(',', $#foo, @foo);
35 $r = join(',', $#bar, @bar);
38 $r = join(',', $#bar, @bar);
41 $r = join(',', $#bar, @bar);
44 $r = join(',', $#bar, @bar);
46 reset 'b' if $^O ne 'VMS';
49 $r = join(',', $#bar, @bar);
52 $r = join(',', $#bar, @bar);
55 $foo = 'now is the time';
56 ok(scalar (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/)));
62 ok(!($cnt = (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/))))
63 or diag("$cnt $F1:$F2:$Etc");
65 %foo = ('blurfl','dyick','foo','bar','etc.','etc.');
67 is($bar{'foo'}, 'bar');
69 is($bar{'foo'}, undef);
70 (%bar,$a,$b) = (%foo,'how','now');
71 is($bar{'foo'}, 'bar');
72 is($bar{'how'}, 'now');
73 @bar{keys %foo} = values %foo;
74 is($bar{'foo'}, 'bar');
75 is($bar{'how'}, 'now');
77 @foo = grep(/e/,split(' ','now is the time for all good men to come to'));
78 is(join(' ',@foo), 'the time men come');
80 @foo = grep(!/e/,split(' ','now is the time for all good men to come to'));
81 is(join(' ',@foo), 'now is for all good to to');
83 $foo = join('',('a','b','c','d','e','f')[0..5]);
86 $foo = join('',('a','b','c','d','e','f')[0..1]);
89 $foo = join('',('a','b','c','d','e','f')[6]);
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]);
97 $foo = ('a','b','c','d','e','f')[0,2,4];
100 $foo = ('a','b','c','d','e','f')[1];
103 @foo = ( 'foo', 'bar', 'burbl', 'blah');
105 # various AASSIGN_COMMON checks (see newASSIGNOP() in op.c)
110 is("@foo", "foo bar burbl blah"); # 37
113 is("@foo", "bar burbl blah"); # 38
115 @foo = ('XXX',@foo, 'YYY');
116 is("@foo", "XXX bar burbl blah YYY"); # 39
118 @foo = @foo = qw(foo b\a\r bu\\rbl blah);
119 is("@foo", 'foo b\a\r bu\\rbl blah'); # 40
121 @bar = @foo = qw(foo bar); # 41
122 is("@foo", "foo bar");
123 is("@bar", "foo bar"); # 42
125 # try the same with local
126 # XXX tie-stdarray fails the tests involving local, so we use
127 # different variable names to escape the 'tie'
129 @bee = ( 'foo', 'bar', 'burbl', 'blah');
133 is("@bee", "foo bar burbl blah"); # 43
135 local (undef,@bee) = @bee;
136 is("@bee", "bar burbl blah"); # 44
138 local @bee = ('XXX',@bee,'YYY');
139 is("@bee", "XXX bar burbl blah YYY"); # 45
141 local @bee = local(@bee) = qw(foo bar burbl blah);
142 is("@bee", "foo bar burbl blah"); # 46
144 local (@bim) = local(@bee) = qw(foo bar);
145 is("@bee", "foo bar"); # 47
146 is("@bim", "foo bar"); # 48
148 is("@bee", "foo bar burbl blah"); # 49
150 is("@bee", "XXX bar burbl blah YYY"); # 50
152 is("@bee", "bar burbl blah"); # 51
154 is("@bee", "foo bar burbl blah"); # 52
157 # try the same with my
160 is("@bee", "foo bar burbl blah"); # 53
162 my (undef,@bee) = @bee;
163 is("@bee", "bar burbl blah"); # 54
165 my @bee = ('XXX',@bee,'YYY');
166 is("@bee", "XXX bar burbl blah YYY"); # 55
168 my @bee = my @bee = qw(foo bar burbl blah);
169 is("@bee", "foo bar burbl blah"); # 56
171 my (@bim) = my(@bee) = qw(foo bar);
172 is("@bee", "foo bar"); # 57
173 is("@bim", "foo bar"); # 58
175 is("@bee", "foo bar burbl blah"); # 59
177 is("@bee", "XXX bar burbl blah YYY"); # 60
179 is("@bee", "bar burbl blah"); # 61
181 is("@bee", "foo bar burbl blah"); # 62
184 # try the same with our (except that previous values aren't restored)
187 is("@bee", "foo bar burbl blah");
189 our (undef,@bee) = @bee;
190 is("@bee", "bar burbl blah");
192 our @bee = ('XXX',@bee,'YYY');
193 is("@bee", "XXX bar burbl blah YYY");
195 our @bee = our @bee = qw(foo bar burbl blah);
196 is("@bee", "foo bar burbl blah");
198 our (@bim) = our(@bee) = qw(foo bar);
199 is("@bee", "foo bar");
200 is("@bim", "foo bar");
207 # make sure reification behaves
209 sub reify { $_[1] = $t++; print "@_\n"; }
215 # qw() is no longer a runtime split, it's compiletime.
216 is (qw(foo bar snorfle)[2], 'snorfle');
218 @ary = (12,23,34,45,56);
222 is(push(@ary,56), 4);
223 is(unshift(@ary,12), 5);
229 # bugid #15439 - clearing an array calls destructors which may try
230 # to modify the array - caused 'Attempt to free unreferenced scalar'
234 sub X::DESTROY { @a = () }
235 @a = (bless {}, q{X});
244 # Test negative and funky indices.
264 like($@, qr/Modification of non-creatable array value attempted, subscript -1/, "\$a[-1] = 0");
270 is ($$ref, undef, "\$# on freed array is undef");
272 local $SIG{__WARN__} = sub {push @warn, "@_"};
274 is (scalar @warn, 1);
275 like ($warn[0], qr/^Attempt to set length of freed array/);
280 # Need a new statement to make it go out of scope
282 test_arylen (do {my @a; \$#a});
288 my $outer = \$#array;
290 is (scalar @array, 0);
294 is (scalar @array, 4);
304 is (scalar @array, 0);
307 is (scalar @$ref, 7);
310 is (scalar @array, 0);
315 is (scalar @array, 7);
318 is ($$inner, undef, "orphaned $#foo is always undef");
320 is (scalar @array, 7);
325 is (scalar @array, 7);
328 $$inner = 503; # Bang!
330 is (scalar @array, 7);
360 # Bug #37350 -- once more with a global
374 # more tests for AASSIGN_COMMON
377 our($x,$y,$z) = (1..3);
378 our($y,$z) = ($x,$y);
379 is("$x $y $z", "1 1 2");
382 our($x,$y,$z) = (1..3);
383 (our $y, our $z) = ($x,$y);
384 is("$x $y $z", "1 1 2");
387 # AASSIGN_COMMON detection with logical operators
389 our($x,$y,$z) = (1..3);
390 (our $y, our $z) = $true && ($x,$y);
391 is("$x $y $z", "1 1 2");
396 my $x = get_x(); my %x = %$x; sub get_x { %x=(1..4); return \%x };
398 join(" ", map +($_,$x{$_}), sort keys %x), "1 2 3 4",
399 'bug 70171 (self-assignment via my %x = %$x)'
401 my $y = get_y(); my @y = @$y; sub get_y { @y=(1..4); return \@y };
404 'bug 70171 (self-assignment via my @x = @$x)'
408 # [perl #70171], [perl #82110]
412 my @a = @$ra; # common assignment on 2nd attempt
413 my %h = %$rh; # common assignment on 2nd attempt
415 %h = qw(a 1 b 2 c 3 d 4);
418 goto again unless $i++;
421 'bug 70171 (self-assignment via my @x = @$x) - goto variant'
424 join(" ", map +($_,$h{$_}), sort keys %h), "a 1 b 2 c 3 d 4",
425 'bug 70171 (self-assignment via my %x = %$x) - goto variant'
430 *trit = *scile; $trit[0];
431 ok(1, 'aelem_fast on a nonexistent array does not crash');
434 sub A::DESTROY { $::ra = 0 }
435 $::ra = [ bless [], 'A' ];
437 pass 'no crash when freeing array that is being undeffed';
438 $::ra = [ bless [], 'A' ];
440 pass 'no crash when freeing array that is being cleared';
442 # [perl #85670] Copying magic to elements
444 skip "no Scalar::Util::weaken on miniperl", 1, if is_miniperl;
445 require Scalar::Util;
447 Scalar::Util::weaken ($a = \@ISA);
449 Scalar::Util::weaken ($a = \$ISA[0]);
450 ::is @ISA, 1, 'backref magic is not copied to elements';
456 $ISA[0] = qw(Sphare);
458 sub Sphare::pling { 'pling' }
460 ::is eval { pling peen }, 'pling',
461 'arylen_p magic does not stop isa magic from being copied';
464 # Test that &PL_sv_undef is not special in arrays
467 'exists returns true for &PL_sv_undef elem [perl #7508]';
468 is \$_[0], \undef, 'undef preserves identity in array [perl #109726]';
470 # and that padav also knows how to handle the resulting NULLs
471 @_ = sub { my @a; $a[1]=1; @a }->();
472 is join (" ", map $_//"undef", @_), "undef 1",
473 'returning my @a with nonexistent elements';
480 is $plink[0], 2, '@_ alias to nonexistent elem within array';
482 is $plink[1], 3, '@_ alias to nonexistent neg index within array';
483 is $_[2], undef, 'reading alias to negative index past beginning';
485 like $@, qr/Modification of non-creatable array value attempted, (?x:
487 'error when setting alias to negative index past beginning';
488 is $_[3], undef, 'reading alias to -1 elem of empty array';
490 like $@, qr/Modification of non-creatable array value attempted, (?x:
492 'error when setting alias to -1 elem of empty array';
493 }->($plink[0], $plink[-2], $plink[-5], $plunk[-1]);
498 pass "no assertion failure after assigning ref to arylen when ary is gone";
502 # Test aelemfast for both +ve and -ve indices, both lex and package vars.
503 # Make especially careful that we don't have any edge cases around
504 # fitting an I8 into a U8.
506 is($a[-256], 300-256, 'lex -256');
507 is($a[-255], 300-255, 'lex -255');
508 is($a[-254], 300-254, 'lex -254');
509 is($a[-129], 300-129, 'lex -129');
510 is($a[-128], 300-128, 'lex -128');
511 is($a[-127], 300-127, 'lex -127');
512 is($a[-126], 300-126, 'lex -126');
513 is($a[ -1], 300- 1, 'lex -1');
514 is($a[ 0], 0, 'lex 0');
515 is($a[ 1], 1, 'lex 1');
516 is($a[ 126], 126, 'lex 126');
517 is($a[ 127], 127, 'lex 127');
518 is($a[ 128], 128, 'lex 128');
519 is($a[ 129], 129, 'lex 129');
520 is($a[ 254], 254, 'lex 254');
521 is($a[ 255], 255, 'lex 255');
522 is($a[ 256], 256, 'lex 256');
524 is($aelem[-256], 300-256, 'pkg -256');
525 is($aelem[-255], 300-255, 'pkg -255');
526 is($aelem[-254], 300-254, 'pkg -254');
527 is($aelem[-129], 300-129, 'pkg -129');
528 is($aelem[-128], 300-128, 'pkg -128');
529 is($aelem[-127], 300-127, 'pkg -127');
530 is($aelem[-126], 300-126, 'pkg -126');
531 is($aelem[ -1], 300- 1, 'pkg -1');
532 is($aelem[ 0], 0, 'pkg 0');
533 is($aelem[ 1], 1, 'pkg 1');
534 is($aelem[ 126], 126, 'pkg 126');
535 is($aelem[ 127], 127, 'pkg 127');
536 is($aelem[ 128], 128, 'pkg 128');
537 is($aelem[ 129], 129, 'pkg 129');
538 is($aelem[ 254], 254, 'pkg 254');
539 is($aelem[ 255], 255, 'pkg 255');
540 is($aelem[ 256], 256, 'pkg 256');
543 "We're included by lib/Tie/Array/std.t so we need to return something true";