1N/Apackage Tie::SubstrHash;
1N/A
1N/Aour $VERSION = '1.00';
1N/A
1N/A=head1 NAME
1N/A
1N/ATie::SubstrHash - Fixed-table-size, fixed-key-length hashing
1N/A
1N/A=head1 SYNOPSIS
1N/A
1N/A require Tie::SubstrHash;
1N/A
1N/A tie %myhash, 'Tie::SubstrHash', $key_len, $value_len, $table_size;
1N/A
1N/A=head1 DESCRIPTION
1N/A
1N/AThe B<Tie::SubstrHash> package provides a hash-table-like interface to
1N/Aan array of determinate size, with constant key size and record size.
1N/A
1N/AUpon tying a new hash to this package, the developer must specify the
1N/Asize of the keys that will be used, the size of the value fields that the
1N/Akeys will index, and the size of the overall table (in terms of key-value
1N/Apairs, not size in hard memory). I<These values will not change for the
1N/Aduration of the tied hash>. The newly-allocated hash table may now have
1N/Adata stored and retrieved. Efforts to store more than C<$table_size>
1N/Aelements will result in a fatal error, as will efforts to store a value
1N/Anot exactly C<$value_len> characters in length, or reference through a
1N/Akey not exactly C<$key_len> characters in length. While these constraints
1N/Amay seem excessive, the result is a hash table using much less internal
1N/Amemory than an equivalent freely-allocated hash table.
1N/A
1N/A=head1 CAVEATS
1N/A
1N/ABecause the current implementation uses the table and key sizes for the
1N/Ahashing algorithm, there is no means by which to dynamically change the
1N/Avalue of any of the initialization parameters.
1N/A
1N/AThe hash does not support exists().
1N/A
1N/A=cut
1N/A
1N/Ause Carp;
1N/A
1N/Asub TIEHASH {
1N/A my $pack = shift;
1N/A my ($klen, $vlen, $tsize) = @_;
1N/A my $rlen = 1 + $klen + $vlen;
1N/A $tsize = [$tsize,
1N/A findgteprime($tsize * 1.1)]; # Allow 10% empty.
1N/A local $self = bless ["\0", $klen, $vlen, $tsize, $rlen, 0, -1];
1N/A $$self[0] x= $rlen * $tsize->[1];
1N/A $self;
1N/A}
1N/A
1N/Asub CLEAR {
1N/A local($self) = @_;
1N/A $$self[0] = "\0" x ($$self[4] * $$self[3]->[1]);
1N/A $$self[5] = 0;
1N/A $$self[6] = -1;
1N/A}
1N/A
1N/Asub FETCH {
1N/A local($self,$key) = @_;
1N/A local($klen, $vlen, $tsize, $rlen) = @$self[1..4];
1N/A &hashkey;
1N/A for (;;) {
1N/A $offset = $hash * $rlen;
1N/A $record = substr($$self[0], $offset, $rlen);
1N/A if (ord($record) == 0) {
1N/A return undef;
1N/A }
1N/A elsif (ord($record) == 1) {
1N/A }
1N/A elsif (substr($record, 1, $klen) eq $key) {
1N/A return substr($record, 1+$klen, $vlen);
1N/A }
1N/A &rehash;
1N/A }
1N/A}
1N/A
1N/Asub STORE {
1N/A local($self,$key,$val) = @_;
1N/A local($klen, $vlen, $tsize, $rlen) = @$self[1..4];
1N/A croak("Table is full ($tsize->[0] elements)") if $$self[5] > $tsize->[0];
1N/A croak(qq/Value "$val" is not $vlen characters long/)
1N/A if length($val) != $vlen;
1N/A my $writeoffset;
1N/A
1N/A &hashkey;
1N/A for (;;) {
1N/A $offset = $hash * $rlen;
1N/A $record = substr($$self[0], $offset, $rlen);
1N/A if (ord($record) == 0) {
1N/A $record = "\2". $key . $val;
1N/A die "panic" unless length($record) == $rlen;
1N/A $writeoffset = $offset unless defined $writeoffset;
1N/A substr($$self[0], $writeoffset, $rlen) = $record;
1N/A ++$$self[5];
1N/A return;
1N/A }
1N/A elsif (ord($record) == 1) {
1N/A $writeoffset = $offset unless defined $writeoffset;
1N/A }
1N/A elsif (substr($record, 1, $klen) eq $key) {
1N/A $record = "\2". $key . $val;
1N/A die "panic" unless length($record) == $rlen;
1N/A substr($$self[0], $offset, $rlen) = $record;
1N/A return;
1N/A }
1N/A &rehash;
1N/A }
1N/A}
1N/A
1N/Asub DELETE {
1N/A local($self,$key) = @_;
1N/A local($klen, $vlen, $tsize, $rlen) = @$self[1..4];
1N/A &hashkey;
1N/A for (;;) {
1N/A $offset = $hash * $rlen;
1N/A $record = substr($$self[0], $offset, $rlen);
1N/A if (ord($record) == 0) {
1N/A return undef;
1N/A }
1N/A elsif (ord($record) == 1) {
1N/A }
1N/A elsif (substr($record, 1, $klen) eq $key) {
1N/A substr($$self[0], $offset, 1) = "\1";
1N/A return substr($record, 1+$klen, $vlen);
1N/A --$$self[5];
1N/A }
1N/A &rehash;
1N/A }
1N/A}
1N/A
1N/Asub FIRSTKEY {
1N/A local($self) = @_;
1N/A $$self[6] = -1;
1N/A &NEXTKEY;
1N/A}
1N/A
1N/Asub NEXTKEY {
1N/A local($self) = @_;
1N/A local($klen, $vlen, $tsize, $rlen, $entries, $iterix) = @$self[1..6];
1N/A for (++$iterix; $iterix < $tsize->[1]; ++$iterix) {
1N/A next unless substr($$self[0], $iterix * $rlen, 1) eq "\2";
1N/A $$self[6] = $iterix;
1N/A return substr($$self[0], $iterix * $rlen + 1, $klen);
1N/A }
1N/A $$self[6] = -1;
1N/A undef;
1N/A}
1N/A
1N/Asub EXISTS {
1N/A croak "Tie::SubstrHash does not support exists()";
1N/A}
1N/A
1N/Asub hashkey {
1N/A croak(qq/Key "$key" is not $klen characters long/)
1N/A if length($key) != $klen;
1N/A $hash = 2;
1N/A for (unpack('C*', $key)) {
1N/A $hash = $hash * 33 + $_;
1N/A &_hashwrap if $hash >= 1e13;
1N/A }
1N/A &_hashwrap if $hash >= $tsize->[1];
1N/A $hash = 1 unless $hash;
1N/A $hashbase = $hash;
1N/A}
1N/A
1N/Asub _hashwrap {
1N/A $hash -= int($hash / $tsize->[1]) * $tsize->[1];
1N/A}
1N/A
1N/Asub rehash {
1N/A $hash += $hashbase;
1N/A $hash -= $tsize->[1] if $hash >= $tsize->[1];
1N/A}
1N/A
1N/A# using POSIX::ceil() would be too heavy, and not all platforms have it.
1N/Asub ceil {
1N/A my $num = shift;
1N/A $num = int($num + 1) unless $num == int $num;
1N/A return $num;
1N/A}
1N/A
1N/A# See:
1N/A#
1N/A# http://www-groups.dcs.st-andrews.ac.uk/~history/HistTopics/Prime_numbers.html
1N/A#
1N/A
1N/Asub findgteprime { # find the smallest prime integer greater than or equal to
1N/A use integer;
1N/A
1N/A my $num = ceil(shift);
1N/A return 2 if $num <= 2;
1N/A
1N/A $num++ unless $num % 2;
1N/A my $i;
1N/A my $sqrtnum = int sqrt $num;
1N/A my $sqrtnumsquared = $sqrtnum * $sqrtnum;
1N/A
1N/A NUM:
1N/A for (;; $num += 2) {
1N/A if ($sqrtnumsquared < $num) {
1N/A $sqrtnum++;
1N/A $sqrtnumsquared = $sqrtnum * $sqrtnum;
1N/A }
1N/A for ($i = 3; $i <= $sqrtnum; $i += 2) {
1N/A next NUM unless $num % $i;
1N/A }
1N/A return $num;
1N/A }
1N/A}
1N/A
1N/A1;