t/op/kvaslice.t

   1 #!./perl -w
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6     require './test.pl';
   7 }
   8
   9 # use strict;
  10
  11 plan tests => 40;
  12
  13 # simple use cases
  14 {
  15     my @a = 'a'..'z';
  16
  17     is( join(':', %a[0,1,2]), '0:a:1:b:2:c', "correct result and order");
  18     is( join(':', %a[2,1,0]), '2:c:1:b:0:a', "correct result and order");
  19     is( join(':', %a[1,0,2]), '1:b:0:a:2:c', "correct result and order");
  20
  21     ok( eq_hash( { %a[5,6] }, { 5 => 'f', 6 => 'g' } ), "correct hash" );
  22
  23     is( join(':', %a[()]), '', "correct result for empty slice");
  24 }
  25
  26 # not existing elements
  27 {
  28     my @a = 'a'..'d';
  29     ok( eq_hash( { %a[3..4] }, { 3 => 'd', 4 => undef } ),
  30         "not existing returned with undef value" );
  31
  32     ok( !exists $a[5], "no autovivification" );
  33 }
  34
  35 # repeated keys
  36 {
  37     my @a = 'a'..'d';
  38     @a = %a[ (1) x 3 ];
  39     ok eq_array( \@a, [ (1 => 'b') x 3 ]), "repetead keys end with repeated results";
  40 }
  41
  42 # scalar context
  43 {
  44     my @warn;
  45     local $SIG{__WARN__} = sub {push @warn, "@_"};
  46
  47     my @a = 'a'..'z';
  48     is eval'scalar %a[4,5,6]', 'g', 'last element in scalar context';
  49
  50     like ($warn[0],
  51      qr/^\%a\[\.\.\.\] in scalar context better written as \$a\[\.\.\.\]/);
  52
  53     eval 'is( scalar %a[5], "f", "correct value");';
  54
  55     is (scalar @warn, 2);
  56     like ($warn[1], qr/^\%a\[5\] in scalar context better written as \$a\[5\]/);
  57 }
  58
  59 # autovivification
  60 {
  61     my @a = 'a'..'b';
  62
  63     my @t = %a[1,2];
  64     is( join(':', map {$_//'undef'} @t), '1:b:2:undef', "correct result");
  65     ok( eq_array( \@a, ['a', 'b'] ), "correct array" );
  66 }
  67
  68 # refs
  69 {
  70     my $a = [ 'a'..'z' ];
  71
  72     is( join(':', %$a[2,3,4]), '2:c:3:d:4:e', "correct result and order");
  73     is( join(':', %{$a}[2,3,4]), '2:c:3:d:4:e', "correct result and order");
  74 }
  75
  76 # no interpolation
  77 {
  78     my @a = 'a'..'b';
  79     is( "%a[1,2]", q{%a[1,2]}, 'no interpolation within strings' );
  80 }
  81
  82 # ref of a slice produces list
  83 {
  84     my @a = 'a'..'z';
  85     my @tmp = \%a[2,3,4];
  86
  87     my $ok = 1;
  88     $ok = 0 if grep !ref, @tmp;
  89     ok $ok, "all elements are refs";
  90
  91     is join( ':', map{ $$_ } @tmp ), '2:c:3:d:4:e';
  92 }
  93
  94 # lvalue usage in foreach
  95 {
  96     my @a = qw(0 1 2 3);
  97     my @i = (1,3);
  98     $_++ foreach %a[@i];
  99     ok( eq_array( \@a, [0,2,2,4] ), "correct array" );
 100     ok( eq_array( \@i, [1,3] ), "indexes not touched" );
 101 }
 102
 103 # lvalue subs in foreach
 104 {
 105     my @a = qw(0 1 2 3);
 106     my @i = (1,3);
 107     sub foo:lvalue{ %a[@i] };
 108     $_++ foreach foo();
 109     ok( eq_array( \@a, [0,2,2,4] ), "correct array" );
 110     ok( eq_array( \@i, [1,3] ), "indexes not touched" );
 111 }
 112
 113 # errors
 114 {
 115     my @a = 'a'..'b';
 116     # no local
 117     {
 118         local $@;
 119         eval 'local %a[1,2]';
 120         like $@, qr{^Can't modify index/value array slice in local at},
 121             'local dies';
 122     }
 123     # no delete
 124     {
 125         local $@;
 126         eval 'delete %a[1,2]';
 127         like $@, qr{^delete argument is index/value array slice, use array slice},
 128             'delete dies';
 129     }
 130     # no assign
 131     {
 132         local $@;
 133         eval '%a[1,2] = qw(B A)';
 134         like $@, qr{^Can't modify index/value array slice in list assignment},
 135             'assign dies';
 136     }
 137     # lvalue subs in assignment
 138     {
 139         local $@;
 140         eval 'sub bar:lvalue{ %a[1,2] }; bar() = "1"';
 141         like $@, qr{^Can't modify index/value array slice in list assignment},
 142             'not allowed as result of lvalue sub';
 143     }
 144 }
 145
 146 # warnings
 147 {
 148     my @warn;
 149     local $SIG{__WARN__} = sub {push @warn, "@_"};
 150
 151     my @a = 'a'..'c';
 152     {
 153         @warn = ();
 154         my $v = eval '%a[0]';
 155         is (scalar @warn, 1, 'warning in scalar context');
 156         like $warn[0],
 157              qr{^%a\[0\] in scalar context better written as \$a\[0\]},
 158             "correct warning text";
 159     }
 160     {
 161         @warn = ();
 162         my ($k,$v) = eval '%a[0]';
 163         is ($k, 0);
 164         is ($v, 'a');
 165         is (scalar @warn, 0, 'no warning in list context');
 166     }
 167 }
 168
 169 # simple case with tied
 170 {
 171     require Tie::Array;
 172     tie my @a, 'Tie::StdArray';
 173     @a = 'a'..'c';
 174
 175     ok( eq_array( [%a[1,2, 3]], [qw(1 b 2 c 3), undef] ),
 176         "works on tied" );
 177
 178     ok( !exists $a[3], "no autovivification" );
 179 }
 180
 181 # keys/value/each treat argument as scalar
 182 {
 183     my %h = 'a'..'b';
 184     my @i = \%h;
 185     no warnings 'syntax', 'experimental::autoderef';
 186     my ($k,$v) = each %i[0];
 187     is $k, 'a', 'key returned by each %array[ix]';
 188     is $v, 'b', 'val returned by each %array[ix]';
 189     %h = 1..10;
 190     is join('-', sort keys %i[(0)]), '1-3-5-7-9', 'keys %array[ix]';
 191     is join('-', sort values %i[(0)]), '10-2-4-6-8', 'values %array[ix]';
 192 }
 193
 194 # \% prototype expects hash deref
 195 sub nowt_but_hash(\%) {}
 196 eval 'nowt_but_hash %_[0]';
 197 like $@, qr`^Type of arg 1 to main::nowt_but_hash must be hash \(not(?x:
 198            ) index/value array slice\) at `,
 199     '\% prototype';