BEGIN {
chdir 't' if -d 't';
@INC = ('.', '../lib');
+ require 'test.pl';
}
-require 'test.pl';
-
-plan (111);
+plan (136);
#
# @foo, @bar, and @ary are also used from tie-stdarray after tie-ing them
is($#ary, 3);
is(join('',@ary), '1234');
-$[ = 1;
-@ary = (1,2,3,4,5);
-is(join('',@ary), '12345');
-
-$tmp = $ary[$#ary]; --$#ary;
-is($tmp, 5);
-# Must do == here beacuse $[ isn't 0
-ok($#ary == 4);
-is(join('',@ary), '1234');
-
-is($ary[5], undef);
-
-$#ary += 1; # see if element 5 gone for good
-ok($#ary == 5);
-ok(!defined $ary[5]);
-
-$[ = 0;
@foo = ();
$r = join(',', $#foo, @foo);
is($r, "-1");
$bar[2] = '2';
$r = join(',', $#bar, @bar);
is($r, "2,0,,2");
-reset 'b';
+reset 'b' if $^O ne 'VMS';
@bar = ();
$bar[0] = '0';
$r = join(',', $#bar, @bar);
is($foo, 'b');
@foo = ( 'foo', 'bar', 'burbl');
-push(foo, 'blah');
+{
+ no warnings 'deprecated';
+ push(foo, 'blah');
+}
is($#foo, 3);
# various AASSIGN_COMMON checks (see newASSIGNOP() in op.c)
# try the same with my
{
-
my @bee = @bee;
is("@bee", "foo bar burbl blah"); # 54
{
is("@bee", "foo bar burbl blah"); # 63
}
+# try the same with our (except that previous values aren't restored)
+{
+ our @bee = @bee;
+ is("@bee", "foo bar burbl blah");
+ {
+ our (undef,@bee) = @bee;
+ is("@bee", "bar burbl blah");
+ {
+ our @bee = ('XXX',@bee,'YYY');
+ is("@bee", "XXX bar burbl blah YYY");
+ {
+ our @bee = our @bee = qw(foo bar burbl blah);
+ is("@bee", "foo bar burbl blah");
+ {
+ our (@bim) = our(@bee) = qw(foo bar);
+ is("@bee", "foo bar");
+ is("@bim", "foo bar");
+ }
+ }
+ }
+ }
+}
+
# make sure reification behaves
my $t = curr_test();
sub reify { $_[1] = $t++; print "@_\n"; }
@foo=(foo())[0,0];
is ($foo[1], "a");
-# $[ should have the same effect regardless of whether the aelem
-# op is optimized to aelemfast.
-
-
-
-sub tary {
- local $[ = 10;
- my $five = 5;
- is ($tary[5], $tary[$five]);
-}
-
-@tary = (0..50);
-tary();
-
-
# bugid #15439 - clearing an array calls destructors which may try
# to modify the array - caused 'Attempt to free unreferenced scalar'
my $got = runperl (
prog => q{
sub X::DESTROY { @a = () }
- @a = (bless {}, 'X');
+ @a = (bless {}, q{X});
@a = ();
},
stderr => 1
}
}
+{
+ # Bug #37350
+ my @array = (1..4);
+ $#{@array} = 7;
+ is ($#{4}, 7);
+
+ my $x;
+ $#{$x} = 3;
+ is(scalar @$x, 4);
+
+ push @{@array}, 23;
+ is ($4[8], 23);
+}
+{
+ # Bug #37350 -- once more with a global
+ use vars '@array';
+ @array = (1..4);
+ $#{@array} = 7;
+ is ($#{4}, 7);
+
+ my $x;
+ $#{$x} = 3;
+ is(scalar @$x, 4);
+
+ push @{@array}, 23;
+ is ($4[8], 23);
+}
+
+# more tests for AASSIGN_COMMON
+
+{
+ our($x,$y,$z) = (1..3);
+ our($y,$z) = ($x,$y);
+ is("$x $y $z", "1 1 2");
+}
+{
+ our($x,$y,$z) = (1..3);
+ (our $y, our $z) = ($x,$y);
+ is("$x $y $z", "1 1 2");
+}
+{
+ # AASSIGN_COMMON detection with logical operators
+ my $true = 1;
+ our($x,$y,$z) = (1..3);
+ (our $y, our $z) = $true && ($x,$y);
+ is("$x $y $z", "1 1 2");
+}
+
+# [perl #70171]
+{
+ my $x = get_x(); my %x = %$x; sub get_x { %x=(1..4); return \%x };
+ is(
+ join(" ", map +($_,$x{$_}), sort keys %x), "1 2 3 4",
+ 'bug 70171 (self-assignment via my %x = %$x)'
+ );
+ my $y = get_y(); my @y = @$y; sub get_y { @y=(1..4); return \@y };
+ is(
+ "@y", "1 2 3 4",
+ 'bug 70171 (self-assignment via my @x = @$x)'
+ );
+}
+
+# [perl #70171], [perl #82110]
+{
+ my ($i, $ra, $rh);
+ again:
+ my @a = @$ra; # common assignment on 2nd attempt
+ my %h = %$rh; # common assignment on 2nd attempt
+ @a = qw(1 2 3 4);
+ %h = qw(a 1 b 2 c 3 d 4);
+ $ra = \@a;
+ $rh = \%h;
+ goto again unless $i++;
+
+ is("@a", "1 2 3 4",
+ 'bug 70171 (self-assignment via my @x = @$x) - goto variant'
+ );
+ is(
+ join(" ", map +($_,$h{$_}), sort keys %h), "a 1 b 2 c 3 d 4",
+ 'bug 70171 (self-assignment via my %x = %$x) - goto variant'
+ );
+}
+
+
+*trit = *scile; $trit[0];
+ok(1, 'aelem_fast on a nonexistent array does not crash');
+
+# [perl #107440]
+sub A::DESTROY { $::ra = 0 }
+$::ra = [ bless [], 'A' ];
+undef @$::ra;
+pass 'no crash when freeing array that is being undeffed';
+$::ra = [ bless [], 'A' ];
+@$::ra = ('a'..'z');
+pass 'no crash when freeing array that is being cleared';
+
+# [perl #85670] Copying magic to elements
+SKIP: {
+ skip "no Scalar::Util::weaken on miniperl", 1, if is_miniperl;
+ require Scalar::Util;
+ package glelp {
+ Scalar::Util::weaken ($a = \@ISA);
+ @ISA = qw(Foo);
+ Scalar::Util::weaken ($a = \$ISA[0]);
+ ::is @ISA, 1, 'backref magic is not copied to elements';
+ }
+}
+package peen {
+ $#ISA = -1;
+ @ISA = qw(Foo);
+ $ISA[0] = qw(Sphare);
+
+ sub Sphare::pling { 'pling' }
+
+ ::is eval { pling peen }, 'pling',
+ 'arylen_p magic does not stop isa magic from being copied';
+}
+
+# Test that &PL_sv_undef is not special in arrays
+sub {
+ ok exists $_[0],
+ 'exists returns true for &PL_sv_undef elem [perl #7508]';
+ is \$_[0], \undef, 'undef preserves identity in array [perl #109726]';
+}->(undef);
+
+# [perl #118691]
+@plink=@plunk=();
+$plink[3] = 1;
+sub {
+ $_[0] = 2;
+ is $plink[0], 2, '@_ alias to nonexistent elem within array';
+ $_[1] = 3;
+ is $plink[1], 3, '@_ alias to nonexistent neg index within array';
+ is $_[2], undef, 'reading alias to negative index past beginning';
+ eval { $_[2] = 42 };
+ like $@, qr/Modification of non-creatable array value attempted, (?x:
+ )subscript -5/,
+ 'error when setting alias to negative index past beginning';
+ is $_[3], undef, 'reading alias to -1 elem of empty array';
+ eval { $_[3] = 42 };
+ like $@, qr/Modification of non-creatable array value attempted, (?x:
+ )subscript -1/,
+ 'error when setting alias to -1 elem of empty array';
+}->($plink[0], $plink[-2], $plink[-5], $plunk[-1]);
+
+$_ = \$#{[]};
+$$_ = \1;
+"$$_";
+pass "no assertion failure after assigning ref to arylen when ary is gone";
+
"We're included by lib/Tie/Array/std.t so we need to return something true";
https://perl5.git.perl.org / perl5.git / blobdiff