contrib/perl5/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 =cut
  37
  38 use Carp;
  39
  40 sub TIEHASH {
  41     my $pack = shift;
  42     my ($klen, $vlen, $tsize) = @_;
  43     my $rlen = 1 + $klen + $vlen;
  44     $tsize = findprime($tsize * 1.1);   # Allow 10% empty.
  45     $self = bless ["\0", $klen, $vlen, $tsize, $rlen, 0, -1];
  46     $$self[0] x= $rlen * $tsize;
  47     $self;
  48 }
  49
  50 sub FETCH {
  51     local($self,$key) = @_;
  52     local($klen, $vlen, $tsize, $rlen) = @$self[1..4];
  53     &hashkey;
  54     for (;;) {
  55         $offset = $hash * $rlen;
  56         $record = substr($$self[0], $offset, $rlen);
  57         if (ord($record) == 0) {
  58             return undef;
  59         }
  60         elsif (ord($record) == 1) {
  61         }
  62         elsif (substr($record, 1, $klen) eq $key) {
  63             return substr($record, 1+$klen, $vlen);
  64         }
  65         &rehash;
  66     }
  67 }
  68
  69 sub STORE {
  70     local($self,$key,$val) = @_;
  71     local($klen, $vlen, $tsize, $rlen) = @$self[1..4];
  72     croak("Table is full") if $$self[5] == $tsize;
  73     croak(qq/Value "$val" is not $vlen characters long./)
  74         if length($val) != $vlen;
  75     my $writeoffset;
  76
  77     &hashkey;
  78     for (;;) {
  79         $offset = $hash * $rlen;
  80         $record = substr($$self[0], $offset, $rlen);
  81         if (ord($record) == 0) {
  82             $record = "\2". $key . $val;
  83             die "panic" unless length($record) == $rlen;
  84             $writeoffset = $offset unless defined $writeoffset;
  85             substr($$self[0], $writeoffset, $rlen) = $record;
  86             ++$$self[5];
  87             return;
  88         }
  89         elsif (ord($record) == 1) {
  90             $writeoffset = $offset unless defined $writeoffset;
  91         }
  92         elsif (substr($record, 1, $klen) eq $key) {
  93             $record = "\2". $key . $val;
  94             die "panic" unless length($record) == $rlen;
  95             substr($$self[0], $offset, $rlen) = $record;
  96             return;
  97         }
  98         &rehash;
  99     }
 100 }
 101
 102 sub DELETE {
 103     local($self,$key) = @_;
 104     local($klen, $vlen, $tsize, $rlen) = @$self[1..4];
 105     &hashkey;
 106     for (;;) {
 107         $offset = $hash * $rlen;
 108         $record = substr($$self[0], $offset, $rlen);
 109         if (ord($record) == 0) {
 110             return undef;
 111         }
 112         elsif (ord($record) == 1) {
 113         }
 114         elsif (substr($record, 1, $klen) eq $key) {
 115             substr($$self[0], $offset, 1) = "\1";
 116             return substr($record, 1+$klen, $vlen);
 117             --$$self[5];
 118         }
 119         &rehash;
 120     }
 121 }
 122
 123 sub FIRSTKEY {
 124     local($self) = @_;
 125     $$self[6] = -1;
 126     &NEXTKEY;
 127 }
 128
 129 sub NEXTKEY {
 130     local($self) = @_;
 131     local($klen, $vlen, $tsize, $rlen, $entries, $iterix) = @$self[1..6];
 132     for (++$iterix; $iterix < $tsize; ++$iterix) {
 133         next unless substr($$self[0], $iterix * $rlen, 1) eq "\2";
 134         $$self[6] = $iterix;
 135         return substr($$self[0], $iterix * $rlen + 1, $klen);
 136     }
 137     $$self[6] = -1;
 138     undef;
 139 }
 140
 141 sub hashkey {
 142     croak(qq/Key "$key" is not $klen characters long.\n/)
 143         if length($key) != $klen;
 144     $hash = 2;
 145     for (unpack('C*', $key)) {
 146         $hash = $hash * 33 + $_;
 147         &_hashwrap if $hash >= 1e13;
 148     }
 149     &_hashwrap if $hash >= $tsize;
 150     $hash = 1 unless $hash;
 151     $hashbase = $hash;
 152 }
 153
 154 sub _hashwrap {
 155     $hash -= int($hash / $tsize) * $tsize;
 156 }
 157
 158 sub rehash {
 159     $hash += $hashbase;
 160     $hash -= $tsize if $hash >= $tsize;
 161 }
 162
 163 sub findprime {
 164     use integer;
 165
 166     my $num = shift;
 167     $num++ unless $num % 2;
 168
 169     $max = int sqrt $num;
 170
 171   NUM:
 172     for (;; $num += 2) {
 173         for ($i = 3; $i <= $max; $i += 2) {
 174             next NUM unless $num % $i;
 175         }
 176         return $num;
 177     }
 178 }
 179
 180 1;