lib/Tie/SubstrHash.pm

   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;