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