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