1package Tie::SubstrHash 1.01; 2 3=head1 NAME 4 5Tie::SubstrHash - Fixed-table-size, fixed-key-length hashing 6 7=head1 SYNOPSIS 8 9 require Tie::SubstrHash; 10 11 tie %myhash, 'Tie::SubstrHash', $key_len, $value_len, $table_size; 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 36The hash does not support exists(). 37 38=cut 39 40use strict; 41use warnings; 42no warnings 'experimental::builtin'; 43 44use Carp; 45 46sub TIEHASH { 47 my ($pack, $klen, $vlen, $tsize) = @_; 48 my $rlen = 1 + $klen + $vlen; 49 $tsize = [$tsize, findgteprime($tsize * 1.1)]; # Allow 10% empty. 50 my $self = bless ["\0", $klen, $vlen, $tsize, $rlen, 0, -1]; 51 $self->[0] x= $rlen * $tsize->[1]; 52 $self; 53} 54 55sub CLEAR { 56 my ($self) = @_; 57 $self->[0] = "\0" x ($self->[4] * $self->[3][1]); 58 $self->[5] = 0; 59 $self->[6] = -1; 60} 61 62sub FETCH { 63 my ($self, $key) = @_; 64 my (undef, $klen, $vlen, $tsize, $rlen) = @$self; 65 my $hashbase = my $hash = hashkey($key, $klen, $tsize); 66 while (1) { 67 my $offset = $hash * $rlen; 68 my $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 $hash = rehash($hash, $hashbase, $tsize); 78 } 79} 80 81sub STORE { 82 my ($self, $key, $val) = @_; 83 my (undef, $klen, $vlen, $tsize, $rlen) = @$self; 84 croak("Table is full ($tsize->[0] elements)") if $self->[5] > $tsize->[0]; 85 croak(qq/Value "$val" is not $vlen characters long/) 86 if length($val) != $vlen; 87 my $writeoffset; 88 89 my $hashbase = my $hash = hashkey($key, $klen, $tsize); 90 while (1) { 91 my $offset = $hash * $rlen; 92 my $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; 97 substr($self->[0], $writeoffset, $rlen) = $record; 98 ++$self->[5]; 99 return; 100 } 101 elsif (ord($record) == 1) { 102 $writeoffset //= $offset; 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 $hash = rehash($hash, $hashbase, $tsize); 111 } 112} 113 114sub DELETE { 115 my ($self, $key) = @_; 116 my (undef, $klen, $vlen, $tsize, $rlen) = @$self; 117 my $hashbase = my $hash = hashkey($key, $klen, $tsize); 118 while (1) { 119 my $offset = $hash * $rlen; 120 my $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 $hash = rehash($hash, $hashbase, $tsize); 132 } 133} 134 135sub FIRSTKEY { 136 my ($self) = @_; 137 $self->[6] = -1; 138 goto &NEXTKEY; 139} 140 141sub NEXTKEY { 142 my ($self) = @_; 143 my (undef, $klen, $vlen, $tsize, $rlen, $entries, $iterix) = @$self; 144 for (++$iterix; $iterix < $tsize->[1]; ++$iterix) { 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 153sub EXISTS { 154 croak "Tie::SubstrHash does not support exists()"; 155} 156 157sub hashkey { 158 my ($key, $klen, $tsize) = @_; 159 croak(qq/Key "$key" is not $klen characters long/) 160 if length($key) != $klen; 161 my $hash = 2; 162 for (unpack('C*', $key)) { 163 $hash = $hash * 33 + $_; 164 $hash = _hashwrap($hash, $tsize) if $hash >= 1e13; 165 } 166 $hash = _hashwrap($hash, $tsize) if $hash >= $tsize->[1]; 167 $hash ||= 1; 168 return $hash; 169} 170 171sub _hashwrap { 172 my ($hash, $tsize) = @_; 173 return $hash - int($hash / $tsize->[1]) * $tsize->[1]; 174} 175 176sub rehash { 177 my ($hash, $hashbase, $tsize) = @_; 178 $hash += $hashbase; 179 $hash -= $tsize->[1] if $hash >= $tsize->[1]; 180 return $hash; 181} 182 183# See: 184# 185# http://www-groups.dcs.st-andrews.ac.uk/~history/HistTopics/Prime_numbers.html 186# 187 188sub findgteprime { # find the smallest prime integer greater than or equal to 189 use integer; 190 191 my $num = builtin::ceil(shift); 192 return 2 if $num <= 2; 193 194 $num++ unless $num % 2; 195 my $sqrtnum = int sqrt $num; 196 my $sqrtnumsquared = $sqrtnum * $sqrtnum; 197 198 NUM: 199 for (;; $num += 2) { 200 if ($sqrtnumsquared < $num) { 201 $sqrtnum++; 202 $sqrtnumsquared = $sqrtnum * $sqrtnum; 203 } 204 for (my $i = 3; $i <= $sqrtnum; $i += 2) { 205 next NUM unless $num % $i; 206 } 207 return $num; 208 } 209} 210 2111; 212