This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
b30e6314ddbc232b83b1a97e26074dbb2940e18e
[perl5.git] / 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';