Jakub Wilk is now a Perl author.
[perl.git] / t / op / kvhslice.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 => 39;
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 assign
121     {
122         local $@;
123         eval '%h{qw(a b)} = qw(B A)';
124         like $@, qr{^Can't modify key/value hash slice in list assignment},
125             'assign dies';
126     }
127     # lvalue subs in assignment
128     {
129         local $@;
130         eval 'sub bar:lvalue{ %h{qw(a b)} }; (bar) = "1"';
131         like $@, qr{^Can't modify key/value hash slice in list assignment},
132             'not allowed as result of lvalue sub';
133         eval 'sub bbar:lvalue{ %h{qw(a b)} }; bbar() = "1"';
134         like $@,
135              qr{^Can't modify key/value hash slice in scalar assignment},
136             'not allowed as result of lvalue sub';
137     }
138 }
139
140 # warnings
141 {
142     my @warn;
143     local $SIG{__WARN__} = sub {push @warn, "@_"};
144
145     my %h = map { $_ => uc $_ } 'a'..'c';
146     {
147         @warn = ();
148         my $v = eval '%h{a}';
149         is (scalar @warn, 1, 'warning in scalar context');
150         like $warn[0],
151              qr{^%h\{"a"\} in scalar context better written as \$h\{"a"\}},
152             "correct warning text";
153     }
154     {
155         @warn = ();
156         my ($k,$v) = eval '%h{a}';
157         is ($k, 'a');
158         is ($v, 'A');
159         is (scalar @warn, 0, 'no warning in list context');
160     }
161
162     {
163         my $h = \%h;
164         eval '%$h->{a}';
165         like($@, qr/Can't use a hash as a reference/, 'hash reference is error' );
166
167         eval '%$h->{"b","c"}';
168         like($@, qr/Can't use a hash as a reference/, 'hash slice reference is error' );
169     }
170 }
171
172 # simple case with tied
173 {
174     require Tie::Hash;
175     tie my %h, 'Tie::StdHash';
176     %h = map { $_ => uc $_ } 'a'..'c';
177
178     ok( eq_array( [%h{'b','a', 'e'}], [qw(b B a A e), undef] ),
179         "works on tied" );
180
181     ok( !exists $h{e}, "no autovivification" );
182 }
183
184 # keys/value/each refuse to compile kvhslice
185 {
186     my %h = 'a'..'b';
187     my %i = (foo => \%h);
188     eval '() = keys %i{foo=>}';
189     like($@, qr/Experimental keys on scalar is now forbidden/,
190          'keys %hash{key} forbidden');
191     eval '() = values %i{foo=>}';
192     like($@, qr/Experimental values on scalar is now forbidden/,
193          'values %hash{key} forbidden');
194     eval '() = each %i{foo=>}';
195     like($@, qr/Experimental each on scalar is now forbidden/,
196          'each %hash{key} forbidden');
197 }
198
199 # \% prototype expects hash deref
200 sub nowt_but_hash(\%) {}
201 eval 'nowt_but_hash %INC{bar}';
202 like $@, qr`^Type of arg 1 to main::nowt_but_hash must be hash \(not(?x:
203            ) key/value hash slice\) at `,
204     '\% prototype';