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