lib/Tie/SubstrHash.pm

   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
  11     tie %myhash, 'Tie::SubstrHash', $key_len, $value_len, $table_size;
  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 The hash does not support exists().
  37
  38 =cut
  39
  40 use Carp;
  41
  42 sub TIEHASH {
  43     my $pack = shift;
  44     my ($klen, $vlen, $tsize) = @_;
  45     my $rlen = 1 + $klen + $vlen;
  46     $tsize = [$tsize,
  47               findgteprime($tsize * 1.1)]; # Allow 10% empty.
  48     $self = bless ["\0", $klen, $vlen, $tsize, $rlen, 0, -1];
  49     $$self[0] x= $rlen * $tsize->[1];
  50     $self;
  51 }
  52
  53 sub CLEAR {
  54     local($self) = @_;
  55     $$self[0] = "\0" x ($$self[4] * $$self[3]->[1]);
  56     $$self[5] =  0;
  57     $$self[6] = -1;
  58 }
  59
  60 sub 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
  79 sub STORE {
  80     local($self,$key,$val) = @_;
  81     local($klen, $vlen, $tsize, $rlen) = @$self[1..4];
  82     croak("Table is full ($tsize->[0] elements)") if $$self[5] > $tsize->[0];
  83     croak(qq/Value "$val" is not $vlen characters long/)
  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
 112 sub 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
 133 sub FIRSTKEY {
 134     local($self) = @_;
 135     $$self[6] = -1;
 136     &NEXTKEY;
 137 }
 138
 139 sub NEXTKEY {
 140     local($self) = @_;
 141     local($klen, $vlen, $tsize, $rlen, $entries, $iterix) = @$self[1..6];
 142     for (++$iterix; $iterix < $tsize->[1]; ++$iterix) {
 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
 151 sub EXISTS {
 152     croak "Tie::SubstrHash does not support exists()";
 153 }
 154
 155 sub hashkey {
 156     croak(qq/Key "$key" is not $klen characters long/)
 157         if length($key) != $klen;
 158     $hash = 2;
 159     for (unpack('C*', $key)) {
 160         $hash = $hash * 33 + $_;
 161         &_hashwrap if $hash >= 1e13;
 162     }
 163     &_hashwrap if $hash >= $tsize->[1];
 164     $hash = 1 unless $hash;
 165     $hashbase = $hash;
 166 }
 167
 168 sub _hashwrap {
 169     $hash -= int($hash / $tsize->[1]) * $tsize->[1];
 170 }
 171
 172 sub rehash {
 173     $hash += $hashbase;
 174     $hash -= $tsize->[1] if $hash >= $tsize->[1];
 175 }
 176
 177 # using POSIX::ceil() would be too heavy, and not all platforms have it.
 178 sub ceil {
 179     my $num = shift;
 180     $num = int($num + 1) unless $num == int $num;
 181     return $num;
 182 }
 183
 184 sub findgteprime { # find the smallest prime integer greater than or equal to
 185     use integer;
 186
 187     my $num = ceil(shift);
 188     return 2 if $num <= 2;
 189
 190     $num++ unless $num % 2;
 191
 192     my $max = int sqrt $num;
 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
 203 1;