test index/value array slices

diff --git a/t/op/kvaslice.t b/t/op/kvaslice.t
new file mode 100644 (file)
index 0000000..d434e3a
--- /dev/null
+++ b/t/op/kvaslice.t
@@ -0,0 +1,179 @@
+#!./perl -w
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    require './test.pl';
+}
+
+# use strict;
+
+plan tests => 35;
+
+# simple use cases
+{
+    my @a = 'a'..'z';
+
+    is( join(':', %a[0,1,2]), '0:a:1:b:2:c', "correct result and order");
+    is( join(':', %a[2,1,0]), '2:c:1:b:0:a', "correct result and order");
+    is( join(':', %a[1,0,2]), '1:b:0:a:2:c', "correct result and order");
+
+    ok( eq_hash( { %a[5,6] }, { 5 => 'f', 6 => 'g' } ), "correct hash" );
+
+    is( join(':', %a[()]), '', "correct result for empty slice");
+}
+
+# not existing elements
+{
+    my @a = 'a'..'d';
+    ok( eq_hash( { %a[3..4] }, { 3 => 'd', 4 => undef } ),
+        "not existing returned with undef value" );
+
+    ok( !exists $a[5], "no autovivification" );
+}
+
+# repeated keys
+{
+    my @a = 'a'..'d';
+    @a = %a[ (1) x 3 ];
+    ok eq_array( \@a, [ (1 => 'b') x 3 ]), "repetead keys end with repeated results";
+}
+
+# scalar context
+{
+    my @a = 'a'..'z';
+    is scalar %a[4,5,6], 'g', 'last element in scalar context';
+
+    {
+        my @warn;
+        local $SIG{__WARN__} = sub {push @warn, "@_"};
+        eval 'is( scalar %a[5], "f", "correct value");';
+
+        is (scalar @warn, 1);
+        like ($warn[0], qr/^Scalar value \%a\[5\] better written as \$a\[5\]/);
+    }
+}
+
+# autovivification
+{
+    my @a = 'a'..'b';
+
+    my @t = %a[1,2];
+    is( join(':', map {$_//'undef'} @t), '1:b:2:undef', "correct result");
+    ok( eq_array( \@a, ['a', 'b'] ), "correct array" );
+}
+
+# refs
+{
+    my $a = [ 'a'..'z' ];
+
+    is( join(':', %$a[2,3,4]), '2:c:3:d:4:e', "correct result and order");
+    is( join(':', %{$a}[2,3,4]), '2:c:3:d:4:e', "correct result and order");
+}
+
+# no interpolation
+{
+    my @a = 'a'..'b';
+    is( "%a[1,2]", q{%a[1,2]}, 'no interpolation within strings' );
+}
+
+# ref of a slice produces list
+{
+    my @a = 'a'..'z';
+    my @tmp = \%a[2,3,4];
+
+    my $ok = 1;
+    $ok = 0 if grep !ref, @tmp;
+    ok $ok, "all elements are refs";
+
+    is join( ':', map{ $$_ } @tmp ), '2:c:3:d:4:e';
+}
+
+# lvalue usage in foreach
+{
+    my @a = qw(0 1 2 3);
+    my @i = (1,3);
+    $_++ foreach %a[@i];
+    ok( eq_array( \@a, [0,2,2,4] ), "correct array" );
+    ok( eq_array( \@i, [1,3] ), "indexes not touched" );
+}
+
+# lvalue subs in foreach
+{
+    my @a = qw(0 1 2 3);
+    my @i = (1,3);
+    sub foo:lvalue{ %a[@i] };
+    $_++ foreach foo();
+    ok( eq_array( \@a, [0,2,2,4] ), "correct array" );
+    ok( eq_array( \@i, [1,3] ), "indexes not touched" );
+}
+
+# errors
+{
+    my @a = 'a'..'b';
+    # no local
+    {
+        local $@;
+        eval 'local %a[1,2]';
+        like $@, qr{^Can't modify index/value array slice in local at},
+            'local dies';
+    }
+    # no delete
+    {
+        local $@;
+        eval 'delete %a[1,2]';
+        like $@, qr{^delete argument is index/value array slice, use array slice},
+            'delete dies';
+    }
+    # no assign
+    {
+        local $@;
+        eval '%a[1,2] = qw(B A)';
+        like $@, qr{^Can't modify index/value array slice in list assignment},
+            'assign dies';
+    }
+    # lvalue subs in assignment
+    {
+        local $@;
+        eval 'sub bar:lvalue{ %a[1,2] }; bar() = "1"';
+        like $@, qr{^Can't modify index/value array slice in list assignment},
+            'not allowed as result of lvalue sub';
+    }
+}
+
+# warnings
+{
+    my @warn;
+    local $SIG{__WARN__} = sub {push @warn, "@_"};
+
+    my @a = 'a'..'c';
+    {
+        @warn = ();
+        my ($v) = eval '%a[0]';
+        is (scalar @warn, 1, 'warning in scalar context');
+        like $warn[0], qr{^Scalar value %a\[0\] better written as \$a\[0\]},
+            "correct warning text";
+    }
+    {
+        @warn = ();
+        my ($k,$v) = eval '%a[0]';
+        is ($k, 0);
+        is ($v, 'a');
+        is (scalar @warn, 1, 'warning, even in list context');
+        like $warn[0], qr{^Scalar value %a\[0\] better written as \$a\[0\]},
+            "correct warning text";
+    }
+}
+
+# simple case with tied
+{
+    require Tie::Array;
+    tie my @a, 'Tie::StdArray';
+    @a = 'a'..'c';
+
+    ok( eq_array( [%a[1,2, 3]], [qw(1 b 2 c 3), undef] ),
+        "works on tied" );
+
+    ok( !exists $a[3], "no autovivification" );
+}
+