This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Quote string argument in example -- necessary if using strict subs
[perl5.git] / lib / Tie / SubstrHash.pm
CommitLineData
64d0c973
RR
1package Tie::SubstrHash;
2
3=head1 NAME
4
5Tie::SubstrHash - Fixed-table-size, fixed-key-length hashing
6
7=head1 SYNOPSIS
8
9 require Tie::SubstrHash;
10
c954a603 11 tie %myhash, 'Tie::SubstrHash', $key_len, $value_len, $table_size;
64d0c973
RR
12
13=head1 DESCRIPTION
14
15The B<Tie::SubstrHash> package provides a hash-table-like interface to
16an array of determinate size, with constant key size and record size.
17
18Upon tying a new hash to this package, the developer must specify the
19size of the keys that will be used, the size of the value fields that the
20keys will index, and the size of the overall table (in terms of key-value
21pairs, not size in hard memory). I<These values will not change for the
22duration of the tied hash>. The newly-allocated hash table may now have
23data stored and retrieved. Efforts to store more than C<$table_size>
24elements will result in a fatal error, as will efforts to store a value
25not exactly C<$value_len> characters in length, or reference through a
26key not exactly C<$key_len> characters in length. While these constraints
27may seem excessive, the result is a hash table using much less internal
28memory than an equivalent freely-allocated hash table.
29
30=head1 CAVEATS
31
32Because the current implementation uses the table and key sizes for the
33hashing algorithm, there is no means by which to dynamically change the
34value of any of the initialization parameters.
35
36=cut
37
748a9306
LW
38use Carp;
39
40sub 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
50sub 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
69sub 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
102sub 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
123sub FIRSTKEY {
124 local($self) = @_;
125 $$self[6] = -1;
126 &NEXTKEY;
127}
128
129sub 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
141sub 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 }
148 $hash = $hash - int($hash / $tsize) * $tsize
149 if $hash >= $tsize;
150 $hash = 1 unless $hash;
151 $hashbase = $hash;
152}
153
154sub rehash {
155 $hash += $hashbase;
156 $hash -= $tsize if $hash >= $tsize;
157}
158
159sub findprime {
160 use integer;
161
162 my $num = shift;
163 $num++ unless $num % 2;
164
165 $max = int sqrt $num;
166
167 NUM:
168 for (;; $num += 2) {
169 for ($i = 3; $i <= $max; $i += 2) {
170 next NUM unless $num % $i;
171 }
172 return $num;
173 }
174}
175
1761;