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