perl 5.002gamma: [patch introduction and re-organisations]
[p5sagit/p5-mst-13.2.git] / 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;