Commit | Line | Data |
---|---|---|
64d0c973 RR |
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 RR |
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 LW |
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]; | |
be425529 | 72 | croak("Table is full") if $$self[5] == $tsize; |
748a9306 LW |
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 LW |
150 | $hash = 1 unless $hash; |
151 | $hashbase = $hash; | |
152 | } | |
153 | ||
77bc6408 | 154 | sub _hashwrap { |
155 | $hash -= int($hash / $tsize) * $tsize; | |
156 | } | |
157 | ||
748a9306 LW |
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; |