X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/2fc04a10ca47a4a5713a39beb29dd8beb9d0f653..d4a823b39f889d5a3c4b03856f90f4d11577e5a0:/t/op/array.t diff --git a/t/op/array.t b/t/op/array.t old mode 100755 new mode 100644 index 6461a43..4c3be2c --- a/t/op/array.t +++ b/t/op/array.t @@ -3,11 +3,10 @@ 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 @@ -21,23 +20,6 @@ is($tmp, 5); 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"); @@ -61,7 +43,7 @@ is($r, "0,0"); $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); @@ -119,7 +101,10 @@ $foo = ('a','b','c','d','e','f')[1]; 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) @@ -176,7 +161,6 @@ is("@bar", "foo bar"); # 43 # try the same with my { - my @bee = @bee; is("@bee", "foo bar burbl blah"); # 54 { @@ -202,6 +186,29 @@ is("@bar", "foo bar"); # 43 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"; } @@ -224,28 +231,13 @@ sub foo { "a" } @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 @@ -356,4 +348,154 @@ sub test_arylen { } } +{ + # 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";