Commit | Line | Data |
---|---|---|
64d0c973 RR |
1 | package Tie::SubstrHash; |
2 | ||
b75c8c73 MS |
3 | our $VERSION = '1.00'; |
4 | ||
64d0c973 RR |
5 | =head1 NAME |
6 | ||
7 | Tie::SubstrHash - Fixed-table-size, fixed-key-length hashing | |
8 | ||
9 | =head1 SYNOPSIS | |
10 | ||
11 | require Tie::SubstrHash; | |
12 | ||
c954a603 | 13 | tie %myhash, 'Tie::SubstrHash', $key_len, $value_len, $table_size; |
64d0c973 RR |
14 | |
15 | =head1 DESCRIPTION | |
16 | ||
17 | The B<Tie::SubstrHash> package provides a hash-table-like interface to | |
18 | an array of determinate size, with constant key size and record size. | |
19 | ||
20 | Upon tying a new hash to this package, the developer must specify the | |
21 | size of the keys that will be used, the size of the value fields that the | |
22 | keys will index, and the size of the overall table (in terms of key-value | |
23 | pairs, not size in hard memory). I<These values will not change for the | |
24 | duration of the tied hash>. The newly-allocated hash table may now have | |
25 | data stored and retrieved. Efforts to store more than C<$table_size> | |
26 | elements will result in a fatal error, as will efforts to store a value | |
27 | not exactly C<$value_len> characters in length, or reference through a | |
28 | key not exactly C<$key_len> characters in length. While these constraints | |
29 | may seem excessive, the result is a hash table using much less internal | |
30 | memory than an equivalent freely-allocated hash table. | |
31 | ||
32 | =head1 CAVEATS | |
33 | ||
34 | Because the current implementation uses the table and key sizes for the | |
35 | hashing algorithm, there is no means by which to dynamically change the | |
36 | value of any of the initialization parameters. | |
37 | ||
2fc7fd3f JH |
38 | The hash does not support exists(). |
39 | ||
64d0c973 RR |
40 | =cut |
41 | ||
748a9306 LW |
42 | use Carp; |
43 | ||
44 | sub TIEHASH { | |
45 | my $pack = shift; | |
46 | my ($klen, $vlen, $tsize) = @_; | |
47 | my $rlen = 1 + $klen + $vlen; | |
2fc7fd3f JH |
48 | $tsize = [$tsize, |
49 | findgteprime($tsize * 1.1)]; # Allow 10% empty. | |
28ee103a | 50 | local $self = bless ["\0", $klen, $vlen, $tsize, $rlen, 0, -1]; |
2fc7fd3f | 51 | $$self[0] x= $rlen * $tsize->[1]; |
748a9306 LW |
52 | $self; |
53 | } | |
54 | ||
2fc7fd3f JH |
55 | sub CLEAR { |
56 | local($self) = @_; | |
57 | $$self[0] = "\0" x ($$self[4] * $$self[3]->[1]); | |
58 | $$self[5] = 0; | |
59 | $$self[6] = -1; | |
60 | } | |
61 | ||
748a9306 LW |
62 | sub FETCH { |
63 | local($self,$key) = @_; | |
64 | local($klen, $vlen, $tsize, $rlen) = @$self[1..4]; | |
65 | &hashkey; | |
66 | for (;;) { | |
67 | $offset = $hash * $rlen; | |
68 | $record = substr($$self[0], $offset, $rlen); | |
69 | if (ord($record) == 0) { | |
70 | return undef; | |
71 | } | |
72 | elsif (ord($record) == 1) { | |
73 | } | |
74 | elsif (substr($record, 1, $klen) eq $key) { | |
75 | return substr($record, 1+$klen, $vlen); | |
76 | } | |
77 | &rehash; | |
78 | } | |
79 | } | |
80 | ||
81 | sub STORE { | |
82 | local($self,$key,$val) = @_; | |
83 | local($klen, $vlen, $tsize, $rlen) = @$self[1..4]; | |
2fc7fd3f JH |
84 | croak("Table is full ($tsize->[0] elements)") if $$self[5] > $tsize->[0]; |
85 | croak(qq/Value "$val" is not $vlen characters long/) | |
748a9306 LW |
86 | if length($val) != $vlen; |
87 | my $writeoffset; | |
88 | ||
89 | &hashkey; | |
90 | for (;;) { | |
91 | $offset = $hash * $rlen; | |
92 | $record = substr($$self[0], $offset, $rlen); | |
93 | if (ord($record) == 0) { | |
94 | $record = "\2". $key . $val; | |
95 | die "panic" unless length($record) == $rlen; | |
96 | $writeoffset = $offset unless defined $writeoffset; | |
97 | substr($$self[0], $writeoffset, $rlen) = $record; | |
98 | ++$$self[5]; | |
99 | return; | |
100 | } | |
101 | elsif (ord($record) == 1) { | |
102 | $writeoffset = $offset unless defined $writeoffset; | |
103 | } | |
104 | elsif (substr($record, 1, $klen) eq $key) { | |
105 | $record = "\2". $key . $val; | |
106 | die "panic" unless length($record) == $rlen; | |
107 | substr($$self[0], $offset, $rlen) = $record; | |
108 | return; | |
109 | } | |
110 | &rehash; | |
111 | } | |
112 | } | |
113 | ||
114 | sub DELETE { | |
115 | local($self,$key) = @_; | |
116 | local($klen, $vlen, $tsize, $rlen) = @$self[1..4]; | |
117 | &hashkey; | |
118 | for (;;) { | |
119 | $offset = $hash * $rlen; | |
120 | $record = substr($$self[0], $offset, $rlen); | |
121 | if (ord($record) == 0) { | |
122 | return undef; | |
123 | } | |
124 | elsif (ord($record) == 1) { | |
125 | } | |
126 | elsif (substr($record, 1, $klen) eq $key) { | |
127 | substr($$self[0], $offset, 1) = "\1"; | |
128 | return substr($record, 1+$klen, $vlen); | |
129 | --$$self[5]; | |
130 | } | |
131 | &rehash; | |
132 | } | |
133 | } | |
134 | ||
135 | sub FIRSTKEY { | |
136 | local($self) = @_; | |
137 | $$self[6] = -1; | |
138 | &NEXTKEY; | |
139 | } | |
140 | ||
141 | sub NEXTKEY { | |
142 | local($self) = @_; | |
143 | local($klen, $vlen, $tsize, $rlen, $entries, $iterix) = @$self[1..6]; | |
2fc7fd3f | 144 | for (++$iterix; $iterix < $tsize->[1]; ++$iterix) { |
748a9306 LW |
145 | next unless substr($$self[0], $iterix * $rlen, 1) eq "\2"; |
146 | $$self[6] = $iterix; | |
147 | return substr($$self[0], $iterix * $rlen + 1, $klen); | |
148 | } | |
149 | $$self[6] = -1; | |
150 | undef; | |
151 | } | |
152 | ||
2fc7fd3f JH |
153 | sub EXISTS { |
154 | croak "Tie::SubstrHash does not support exists()"; | |
155 | } | |
156 | ||
748a9306 | 157 | sub hashkey { |
2fc7fd3f | 158 | croak(qq/Key "$key" is not $klen characters long/) |
748a9306 LW |
159 | if length($key) != $klen; |
160 | $hash = 2; | |
161 | for (unpack('C*', $key)) { | |
162 | $hash = $hash * 33 + $_; | |
77bc6408 | 163 | &_hashwrap if $hash >= 1e13; |
748a9306 | 164 | } |
2fc7fd3f | 165 | &_hashwrap if $hash >= $tsize->[1]; |
748a9306 LW |
166 | $hash = 1 unless $hash; |
167 | $hashbase = $hash; | |
168 | } | |
169 | ||
77bc6408 | 170 | sub _hashwrap { |
2fc7fd3f | 171 | $hash -= int($hash / $tsize->[1]) * $tsize->[1]; |
77bc6408 | 172 | } |
173 | ||
748a9306 LW |
174 | sub rehash { |
175 | $hash += $hashbase; | |
2fc7fd3f JH |
176 | $hash -= $tsize->[1] if $hash >= $tsize->[1]; |
177 | } | |
178 | ||
179 | # using POSIX::ceil() would be too heavy, and not all platforms have it. | |
180 | sub ceil { | |
181 | my $num = shift; | |
182 | $num = int($num + 1) unless $num == int $num; | |
183 | return $num; | |
748a9306 LW |
184 | } |
185 | ||
0bee9efe JL |
186 | # See: |
187 | # | |
188 | # http://www-groups.dcs.st-andrews.ac.uk/~history/HistTopics/Prime_numbers.html | |
189 | # | |
190 | ||
2fc7fd3f | 191 | sub findgteprime { # find the smallest prime integer greater than or equal to |
748a9306 LW |
192 | use integer; |
193 | ||
2fc7fd3f JH |
194 | my $num = ceil(shift); |
195 | return 2 if $num <= 2; | |
196 | ||
748a9306 | 197 | $num++ unless $num % 2; |
0bee9efe JL |
198 | my $i; |
199 | my $sqrtnum = int sqrt $num; | |
200 | my $sqrtnumsquared = $sqrtnum * $sqrtnum; | |
748a9306 | 201 | |
748a9306 LW |
202 | NUM: |
203 | for (;; $num += 2) { | |
0bee9efe JL |
204 | if ($sqrtnumsquared < $num) { |
205 | $sqrtnum++; | |
206 | $sqrtnumsquared = $sqrtnum * $sqrtnum; | |
207 | } | |
208 | for ($i = 3; $i <= $sqrtnum; $i += 2) { | |
1725693f JH |
209 | next NUM unless $num % $i; |
210 | } | |
211 | return $num; | |
748a9306 LW |
212 | } |
213 | } | |
214 | ||
215 | 1; |