t/op/kvaslice.t

   1 #!./perl -w
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     require './test.pl';
   6     set_up_inc('../lib');
   7 }
   8
   9 # use strict;
  10
  11 plan tests => 38;
  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 assign
 124     {
 125         local $@;
 126         eval '%a[1,2] = qw(B A)';
 127         like $@, qr{^Can't modify index/value array slice in list assignment},
 128             'assign dies';
 129     }
 130     # lvalue subs in assignment
 131     {
 132         local $@;
 133         eval 'sub bar:lvalue{ %a[1,2] }; bar() = "1"';
 134         like $@, qr{^Can't modify index/value array slice in list assignment},
 135             'not allowed as result of lvalue sub';
 136     }
 137 }
 138
 139 # warnings
 140 {
 141     my @warn;
 142     local $SIG{__WARN__} = sub {push @warn, "@_"};
 143
 144     my @a = 'a'..'c';
 145     {
 146         @warn = ();
 147         my $v = eval '%a[0]';
 148         is (scalar @warn, 1, 'warning in scalar context');
 149         like $warn[0],
 150              qr{^%a\[0\] in scalar context better written as \$a\[0\]},
 151             "correct warning text";
 152     }
 153     {
 154         @warn = ();
 155         my ($k,$v) = eval '%a[0]';
 156         is ($k, 0);
 157         is ($v, 'a');
 158         is (scalar @warn, 0, 'no warning in list context');
 159     }
 160 }
 161
 162 # simple case with tied
 163 {
 164     require Tie::Array;
 165     tie my @a, 'Tie::StdArray';
 166     @a = 'a'..'c';
 167
 168     ok( eq_array( [%a[1,2, 3]], [qw(1 b 2 c 3), undef] ),
 169         "works on tied" );
 170
 171     ok( !exists $a[3], "no autovivification" );
 172 }
 173
 174 # keys/value/each refuse to compile kvaslice
 175 {
 176     my %h = 'a'..'b';
 177     my @i = \%h;
 178     eval '() = keys %i[(0)]';
 179     like($@, qr/Experimental keys on scalar is now forbidden/,
 180          'keys %array[ix] forbidden');
 181     eval '() = values %i[(0)]';
 182     like($@, qr/Experimental values on scalar is now forbidden/,
 183          'values %array[ix] forbidden');
 184     eval '() = each %i[(0)]';
 185     like($@, qr/Experimental each on scalar is now forbidden/,
 186          'each %array[ix] forbidden');
 187 }
 188
 189 # \% prototype expects hash deref
 190 sub nowt_but_hash(\%) {}
 191 eval 'nowt_but_hash %_[0]';
 192 like $@, qr`^Type of arg 1 to main::nowt_but_hash must be hash \(not(?x:
 193            ) index/value array slice\) at `,
 194     '\% prototype';