home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl501m.zip / lib / SubstrHash.pm < prev    next >
Text File  |  1995-03-16  |  3KB  |  141 lines
  1. package SubstrHash;
  2. use Carp;
  3.  
  4. sub TIEHASH {
  5.     my $pack = shift;
  6.     my ($klen, $vlen, $tsize) = @_;
  7.     my $rlen = 1 + $klen + $vlen;
  8.     $tsize = findprime($tsize * 1.1);    # Allow 10% empty.
  9.     $self = bless ["\0", $klen, $vlen, $tsize, $rlen, 0, -1];
  10.     $$self[0] x= $rlen * $tsize;
  11.     $self;
  12. }
  13.  
  14. sub FETCH {
  15.     local($self,$key) = @_;
  16.     local($klen, $vlen, $tsize, $rlen) = @$self[1..4];
  17.     &hashkey;
  18.     for (;;) {
  19.     $offset = $hash * $rlen;
  20.     $record = substr($$self[0], $offset, $rlen);
  21.     if (ord($record) == 0) {
  22.         return undef;
  23.     }
  24.     elsif (ord($record) == 1) {
  25.     }
  26.     elsif (substr($record, 1, $klen) eq $key) {
  27.         return substr($record, 1+$klen, $vlen);
  28.     }
  29.     &rehash;
  30.     }
  31. }
  32.  
  33. sub STORE {
  34.     local($self,$key,$val) = @_;
  35.     local($klen, $vlen, $tsize, $rlen) = @$self[1..4];
  36.     croak("Table is full") if $self[5] == $tsize;
  37.     croak(qq/Value "$val" is not $vlen characters long./)
  38.     if length($val) != $vlen;
  39.     my $writeoffset;
  40.  
  41.     &hashkey;
  42.     for (;;) {
  43.     $offset = $hash * $rlen;
  44.     $record = substr($$self[0], $offset, $rlen);
  45.     if (ord($record) == 0) {
  46.         $record = "\2". $key . $val;
  47.         die "panic" unless length($record) == $rlen;
  48.         $writeoffset = $offset unless defined $writeoffset;
  49.         substr($$self[0], $writeoffset, $rlen) = $record;
  50.         ++$$self[5];
  51.         return;
  52.     }
  53.     elsif (ord($record) == 1) {
  54.         $writeoffset = $offset unless defined $writeoffset;
  55.     }
  56.     elsif (substr($record, 1, $klen) eq $key) {
  57.         $record = "\2". $key . $val;
  58.         die "panic" unless length($record) == $rlen;
  59.         substr($$self[0], $offset, $rlen) = $record;
  60.         return;
  61.     }
  62.     &rehash;
  63.     }
  64. }
  65.  
  66. sub DELETE {
  67.     local($self,$key) = @_;
  68.     local($klen, $vlen, $tsize, $rlen) = @$self[1..4];
  69.     &hashkey;
  70.     for (;;) {
  71.     $offset = $hash * $rlen;
  72.     $record = substr($$self[0], $offset, $rlen);
  73.     if (ord($record) == 0) {
  74.         return undef;
  75.     }
  76.     elsif (ord($record) == 1) {
  77.     }
  78.     elsif (substr($record, 1, $klen) eq $key) {
  79.         substr($$self[0], $offset, 1) = "\1";
  80.         return substr($record, 1+$klen, $vlen);
  81.         --$$self[5];
  82.     }
  83.     &rehash;
  84.     }
  85. }
  86.  
  87. sub FIRSTKEY {
  88.     local($self) = @_;
  89.     $$self[6] = -1;
  90.     &NEXTKEY;
  91. }
  92.  
  93. sub NEXTKEY {
  94.     local($self) = @_;
  95.     local($klen, $vlen, $tsize, $rlen, $entries, $iterix) = @$self[1..6];
  96.     for (++$iterix; $iterix < $tsize; ++$iterix) {
  97.     next unless substr($$self[0], $iterix * $rlen, 1) eq "\2";
  98.     $$self[6] = $iterix;
  99.     return substr($$self[0], $iterix * $rlen + 1, $klen);
  100.     }
  101.     $$self[6] = -1;
  102.     undef;
  103. }
  104.  
  105. sub hashkey {
  106.     croak(qq/Key "$key" is not $klen characters long.\n/)
  107.     if length($key) != $klen;
  108.     $hash = 2;
  109.     for (unpack('C*', $key)) {
  110.     $hash = $hash * 33 + $_;
  111.     }
  112.     $hash = $hash - int($hash / $tsize) * $tsize
  113.     if $hash >= $tsize;
  114.     $hash = 1 unless $hash;
  115.     $hashbase = $hash;
  116. }
  117.  
  118. sub rehash {
  119.     $hash += $hashbase;
  120.     $hash -= $tsize if $hash >= $tsize;
  121. }
  122.  
  123. sub findprime {
  124.     use integer;
  125.  
  126.     my $num = shift;
  127.     $num++ unless $num % 2;
  128.  
  129.     $max = int sqrt $num;
  130.  
  131.   NUM:
  132.     for (;; $num += 2) {
  133.     for ($i = 3; $i <= $max; $i += 2) {
  134.         next NUM unless $num % $i;
  135.     }
  136.     return $num;
  137.     }
  138. }
  139.  
  140. 1;
  141.