This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
remove unneeded an unwelcome dependency
[perl5.git] / t / op / hash.t
CommitLineData
05619474
NC
1#!./perl -w
2
3BEGIN {
4 chdir 't' if -d 't';
05619474 5 require './test.pl';
43ece5b1 6 set_up_inc('../lib');
05619474
NC
7}
8
9use strict;
cf8db57b 10
a5a709ec
BM
11# This will crash perl if it fails
12
13use constant PVBM => 'foo';
14
15my $dummy = index 'foo', PVBM;
16eval { my %h = (a => PVBM); 1 };
17
18ok (!$@, 'fbm scalar can be inserted into a hash');
0607bed5
EB
19
20
21my $destroyed;
22{ package Class; DESTROY { ++$destroyed; } }
23
24$destroyed = 0;
25{
26 my %h;
27 keys(%h) = 1;
28 $h{key} = bless({}, 'Class');
29}
2154eca7 30is($destroyed, 1, 'Timely hash destruction with lvalue keys');
04698ff6
FC
31
32
33# [perl #79178] Hash keys must not be stringified during compilation
34# Run perl -MO=Concise -e '$a{\"foo"}' on a non-threaded pre-5.13.8 version
35# to see why.
36{
37 my $key;
38 package bar;
39 sub TIEHASH { bless {}, $_[0] }
40 sub FETCH { $key = $_[1] }
41 package main;
42 tie my %h, "bar";
3349954c 43 () = $h{\'foo'};
04698ff6 44 is ref $key, SCALAR =>
649c173f
FC
45 'ref hash keys are not stringified during compilation';
46 use constant u => undef;
47 no warnings 'uninitialized'; # work around unfixed bug #105918
48 () = $h{+u};
49 is $key, undef,
50 'undef hash keys are not stringified during compilation, either';
04698ff6 51}
2ad76169
FC
52
53# Part of RT #85026: Deleting the current iterator in void context does not
54# free it.
55{
56 my $gone;
57 no warnings 'once';
58 local *::DESTROY = sub { ++$gone };
59 my %a=(a=>bless[]);
60 each %a; # make the entry with the obj the current iterator
61 delete $a{a};
62 ok $gone, 'deleting the current iterator in void context frees the val'
63}
70582212
FC
64
65# [perl #99660] Deleted hash element visible to destructor
66{
67 my %h;
68 $h{k} = bless [];
69 my $normal_exit;
70 local *::DESTROY = sub { my $x = $h{k}; ++$normal_exit };
71 delete $h{k}; # must be in void context to trigger the bug
72 ok $normal_exit, 'freed hash elems are not visible to DESTROY';
73}
ab97dcc3 74
3b2cd809
FC
75# [perl #100340] Similar bug: freeing a hash elem during a delete
76sub guard::DESTROY {
77 ${$_[0]}->();
78};
79*guard = sub (&) {
80 my $callback = shift;
81 return bless \$callback, "guard"
82};
83{
84 my $ok;
85 my %t; %t = (
86 stash => {
87 guard => guard(sub{
88 $ok++;
89 delete $t{stash};
90 }),
91 foo => "bar",
92 bar => "baz",
93 },
94 );
95 ok eval { delete $t{stash}{guard}; # must be in void context
96 1 },
97 'freeing a hash elem from destructor called by delete does not die';
98 diag $@ if $@; # panic: free from wrong pool
99 is $ok, 1, 'the destructor was called';
100}
101
ab97dcc3 102# Weak references to pad hashes
fc67feea 103SKIP: {
ab97dcc3
FC
104 skip_if_miniperl("No Scalar::Util::weaken under miniperl", 1);
105 my $ref;
106 require Scalar::Util;
107 {
108 my %hash;
109 Scalar::Util::weaken($ref = \%hash);
110 1; # the previous statement must not be the last
111 }
112 is $ref, undef, 'weak refs to pad hashes go stale on scope exit';
113}
9f71cfe6
FC
114
115# [perl #107440]
116sub A::DESTROY { $::ra = 0 }
117$::ra = {a=>bless [], 'A'};
118undef %$::ra;
119pass 'no crash when freeing hash that is being undeffed';
120$::ra = {a=>bless [], 'A'};
121%$::ra = ('a'..'z');
122pass 'no crash when freeing hash that is being exonerated, ahem, cleared';
2fff5797
NC
123
124# If I have these correct then removing any part of the lazy hash fill handling
125# code in hv.c will cause some of these tests to start failing.
126sub validate_hash {
127 my ($desc, $h) = @_;
128 local $::Level = $::Level + 1;
129
8bf4c401
YO
130 # test that scalar(%hash) works as expected, which as of perl 5.25 is
131 # the same as 0+keys %hash;
132 my $scalar= scalar %$h;
133 my $count= 0+keys %$h;
134
135 is($scalar, $count, "$desc scalar() should be the same as 0+keys() as of perl 5.25");
136
cf8db57b
JH
137 require Hash::Util;
138 sub Hash::Util::bucket_ratio (\%);
139
8bf4c401
YO
140 # back compat tests, via Hash::Util::bucket_ratio();
141 my $ratio = Hash::Util::bucket_ratio(%$h);
2fff5797 142 my $expect = qr!\A(\d+)/(\d+)\z!;
8bf4c401
YO
143 like($ratio, $expect, "$desc bucket_ratio matches pattern");
144 my ($used, $total)= (0,0);
145 ($used, $total)= ($1,$2) if $ratio =~ /$expect/;
2fff5797
NC
146 cmp_ok($total, '>', 0, "$desc has >0 array size ($total)");
147 cmp_ok($used, '>', 0, "$desc uses >0 heads ($used)");
148 cmp_ok($used, '<=', $total,
149 "$desc doesn't use more heads than are available");
150 return ($used, $total);
151}
152
153sub torture_hash {
154 my $desc = shift;
155 # Intentionally use an anon hash rather than a lexical, as lexicals default
156 # to getting reused on subsequent calls
157 my $h = {};
158 ++$h->{$_} foreach @_;
159
160 my ($used0, $total0) = validate_hash($desc, $h);
161 # Remove half the keys each time round, until there are only 1 or 2 left
162 my @groups;
163 my ($h2, $h3, $h4);
164 while (keys %$h > 2) {
165 my $take = (keys %$h) / 2 - 1;
6f019ba7
YO
166 my @keys = (sort keys %$h)[0..$take];
167
2fff5797
NC
168 my $scalar = %$h;
169 delete @$h{@keys};
170 push @groups, $scalar, \@keys;
171
172 my $count = keys %$h;
173 my ($used, $total) = validate_hash("$desc (-$count)", $h);
174 is($total, $total0, "$desc ($count) has same array size");
175 cmp_ok($used, '<=', $used0, "$desc ($count) has same or fewer heads");
176 ++$h2->{$_} foreach @keys;
177 my (undef, $total2) = validate_hash("$desc (+$count)", $h2);
178 cmp_ok($total2, '<=', $total0, "$desc ($count) array size no larger");
179
180 # Each time this will get emptied then repopulated. If the fill isn't reset
181 # when the hash is emptied, the used count will likely exceed the array
182 %$h3 = %$h2;
6f019ba7 183 is(join(",", sort keys %$h3),join(",",sort keys %$h2),"$desc (+$count copy) has same keys");
2fff5797 184 my (undef, $total3) = validate_hash("$desc (+$count copy)", $h3);
6f019ba7
YO
185 # We now only split when we collide on insert AND exceed the load factor
186 # when we did so. Building a hash via %x=%y means a pseudo-random key
187 # order inserting into %x, and we may end up encountering a collision
188 # at a different point in the load order, resulting in a possible power of
189 # two difference under the current load factor expectations. If this test
190 # fails then it is probably because DO_HSPLIT was changed, and this test
191 # needs to be adjusted accordingly.
192 ok( $total2 == $total3 || $total2*2==$total3 || $total2==$total3*2,
193 "$desc (+$count copy) array size within a power of 2 of each other");
2fff5797
NC
194
195 # This might use fewer buckets than the original
196 %$h4 = %$h;
197 my (undef, $total4) = validate_hash("$desc ($count copy)", $h4);
198 cmp_ok($total4, '<=', $total0, "$desc ($count copy) array size no larger");
199 }
200
201 my $scalar = %$h;
6f019ba7 202 my @keys = sort keys %$h;
2fff5797
NC
203 delete @$h{@keys};
204 is(scalar %$h, 0, "scalar keys for empty $desc");
205
206 # Rebuild the original hash, and build a copy
207 # These will fail if hash key addition and deletion aren't handled correctly
208 my $h1;
209 foreach (@keys) {
210 ++$h->{$_};
211 ++$h1->{$_};
212 }
213 is(scalar %$h, $scalar, "scalar keys restored when rebuilding");
214
215 while (@groups) {
216 my $keys = pop @groups;
217 ++$h->{$_} foreach @$keys;
6f019ba7 218 my (undef, $total) = validate_hash($desc, $h);
2fff5797
NC
219 is($total, $total0, "bucket count is constant when rebuilding");
220 is(scalar %$h, pop @groups, "scalar keys is identical when rebuilding");
221 ++$h1->{$_} foreach @$keys;
6f019ba7 222 validate_hash("$desc copy", $h1);
2fff5797
NC
223 }
224 # This will fail if the fill count isn't handled correctly on hash split
225 is(scalar %$h1, scalar %$h, "scalar keys is identical on copy and original");
226}
227
cf8db57b
JH
228if (is_miniperl) {
229 print "# skipping torture_hash tests on miniperl because no Hash::Util\n";
230} else {
231 torture_hash('a .. zz', 'a' .. 'zz');
232 torture_hash('0 .. 9', 0 .. 9);
233 torture_hash("'Perl'", 'Rules');
234}
2fff5797 235
a5f48505
DM
236{
237 my %h = qw(a x b y c z);
238 no warnings qw(misc uninitialized);
239 %h = $h{a};
240 is(join(':', %h), 'x:', 'hash self-assign');
241}
242
8b0c3377
DM
243# magic keys and values should be evaluated before the hash on the LHS is
244# cleared
245
246package Magic {
247 my %inner;
248 sub TIEHASH { bless [] }
249 sub FETCH { $inner{$_[1]} }
250 sub STORE { $inner{$_[1]} = $_[2]; }
251 sub CLEAR { %inner = () }
252
253 my (%t1, %t2);
254 tie %t1, 'Magic';
255 tie %t2, 'Magic';
256
257 %inner = qw(a x b y);
258 %t1 = (@t2{'a','b'});
259 ::is(join( ':', %inner), "x:y", "magic keys");
260}
261
262
263
2fff5797 264done_testing();