gv:gv_try_downgrade: Leave PL_stderrgv alone

[perl5.git] / t / op / kvaslice.t

#!./perl -w

BEGIN {
    chdir 't' if -d 't';
    @INC = '../lib';
    require './test.pl';
}

# use strict;

plan tests => 39;

# 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, 0, 'no warning in list context');
    }
}

# 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" );
}

# keys/value/each treat argument as scalar
{
    my %h = 'a'..'b';
    my @i = \%h;
    my ($k,$v) = each %i[(0)]; # parens suppress "Scalar better written as"
    is $k, 'a', 'key returned by each %array[ix]';
    is $v, 'b', 'val returned by each %array[ix]';
    %h = 1..10;
    is join('-', sort keys %i[(0)]), '1-3-5-7-9', 'keys %array[ix]';
    is join('-', sort values %i[(0)]), '10-2-4-6-8', 'values %array[ix]';
}

# \% prototype expects hash deref
sub nowt_but_hash(\%) {}
eval 'nowt_but_hash %_[0]';
like $@, qr`^Type of arg 1 to main::nowt_but_hash must be hash \(not(?x:
           ) index/value array slice\) at `,
    '\% prototype';