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