home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl_mlb.zip / Tie / SubstrHash.pm < prev   
Text File  |  1997-11-25  |  5KB  |  181 lines
  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;
  181.