1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
|
#!./perl -w
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
}
use strict;
plan tests => 10;
my %h;
ok (!Internals::HvREHASH(%h), "hash doesn't start with rehash flag on");
foreach (1..10) {
$h{"\0"x$_}++;
}
ok (!Internals::HvREHASH(%h), "10 entries doesn't trigger rehash");
foreach (11..20) {
$h{"\0"x$_}++;
}
ok (Internals::HvREHASH(%h), "20 entries triggers rehash");
# second part using an emulation of the PERL_HASH in perl, mounting an
# attack on a pre-populated hash. This is also useful if you need normal
# keys which don't contain \0 -- suitable for stashes
use constant MASK_U32 => 2**32;
use constant HASH_SEED => 0;
use constant THRESHOLD => 14;
use constant START => "a";
# some initial hash data
my %h2 = map {$_ => 1} 'a'..'cc';
ok (!Internals::HvREHASH(%h2),
"starting with pre-populated non-pathological hash (rehash flag if off)");
my @keys = get_keys(\%h2);
$h2{$_}++ for @keys;
ok (Internals::HvREHASH(%h2),
scalar(@keys) . " colliding into the same bucket keys are triggering rehash");
sub get_keys {
my $hr = shift;
# the minimum of bits required to mount the attack on a hash
my $min_bits = log(THRESHOLD)/log(2);
# if the hash has already been populated with a significant amount
# of entries the number of mask bits can be higher
my $keys = scalar keys %$hr;
my $bits = $keys ? log($keys)/log(2) : 0;
$bits = $min_bits if $min_bits > $bits;
$bits = int($bits) < $bits ? int($bits) + 1 : int($bits);
# need to add 2 bits to cover the internal split cases
$bits += 2;
my $mask = 2**$bits-1;
print "# using mask: $mask ($bits)\n";
my @keys;
my $s = START;
my $c = 0;
# get 2 keys on top of the THRESHOLD
my $hash;
while (@keys < THRESHOLD+2) {
# next if exists $hash->{$s};
$hash = hash($s);
next unless ($hash & $mask) == 0;
$c++;
printf "# %2d: %5s, %10s\n", $c, $s, $hash;
push @keys, $s;
} continue {
$s++;
}
return @keys;
}
# trying to provide the fastest equivalent of C macro's PERL_HASH in
# Perl - the main complication is that it uses U32 integer, which we
# can't do it perl, without doing some tricks
sub hash {
my $s = shift;
my @c = split //, $s;
my $u = HASH_SEED;
for (@c) {
# (A % M) + (B % M) == (A + B) % M
# This works because '+' produces a NV, which is big enough to hold
# the intermediate result. We only need the % before any "^" and "&"
# to get the result in the range for an I32.
# and << doesn't work on NV, so using 1 << 10
$u += ord;
$u += $u * (1 << 10); $u %= MASK_U32;
$u ^= $u >> 6;
}
$u += $u << 3; $u %= MASK_U32;
$u ^= $u >> 11; $u %= MASK_U32;
$u += $u << 15; $u %= MASK_U32;
$u;
}
# This will crash perl if it fails
use constant PVBM => 'foo';
my $dummy = index 'foo', PVBM;
eval { my %h = (a => PVBM); 1 };
ok (!$@, 'fbm scalar can be inserted into a hash');
my $destroyed;
{ package Class; DESTROY { ++$destroyed; } }
$destroyed = 0;
{
my %h;
keys(%h) = 1;
$h{key} = bless({}, 'Class');
}
is($destroyed, 1, 'Timely hash destruction with lvalue keys');
# [perl #79178] Hash keys must not be stringified during compilation
# Run perl -MO=Concise -e '$a{\"foo"}' on a non-threaded pre-5.13.8 version
# to see why.
{
my $key;
package bar;
sub TIEHASH { bless {}, $_[0] }
sub FETCH { $key = $_[1] }
package main;
tie my %h, "bar";
() = $h{\'foo'};
is ref $key, SCALAR =>
'hash keys are not stringified during compilation';
}
# Part of RT #85026: Deleting the current iterator in void context does not
# free it.
{
my $gone;
no warnings 'once';
local *::DESTROY = sub { ++$gone };
my %a=(a=>bless[]);
each %a; # make the entry with the obj the current iterator
delete $a{a};
ok $gone, 'deleting the current iterator in void context frees the val'
}
# [perl #99660] Deleted hash element visible to destructor
{
my %h;
$h{k} = bless [];
my $normal_exit;
local *::DESTROY = sub { my $x = $h{k}; ++$normal_exit };
delete $h{k}; # must be in void context to trigger the bug
ok $normal_exit, 'freed hash elems are not visible to DESTROY';
}
|
