lib/Tie/SubstrHash.pm

package Tie::SubstrHash;

our $VERSION = '1.00';

=head1 NAME

Tie::SubstrHash - Fixed-table-size, fixed-key-length hashing

=head1 SYNOPSIS

    require Tie::SubstrHash;

    tie %myhash, 'Tie::SubstrHash', $key_len, $value_len, $table_size;

=head1 DESCRIPTION

The B<Tie::SubstrHash> package provides a hash-table-like interface to
an array of determinate size, with constant key size and record size.

Upon tying a new hash to this package, the developer must specify the
size of the keys that will be used, the size of the value fields that the
keys will index, and the size of the overall table (in terms of key-value
pairs, not size in hard memory). I<These values will not change for the
duration of the tied hash>. The newly-allocated hash table may now have
data stored and retrieved. Efforts to store more than C<$table_size>
elements will result in a fatal error, as will efforts to store a value
not exactly C<$value_len> characters in length, or reference through a
key not exactly C<$key_len> characters in length. While these constraints
may seem excessive, the result is a hash table using much less internal
memory than an equivalent freely-allocated hash table.

=head1 CAVEATS

Because the current implementation uses the table and key sizes for the
hashing algorithm, there is no means by which to dynamically change the
value of any of the initialization parameters.

The hash does not support exists().

=cut

use Carp;

sub TIEHASH {
    my $pack = shift;
    my ($klen, $vlen, $tsize) = @_;
    my $rlen = 1 + $klen + $vlen;
    $tsize = [$tsize,
              findgteprime($tsize * 1.1)]; # Allow 10% empty.
    local $self = bless ["\0", $klen, $vlen, $tsize, $rlen, 0, -1];
    $$self[0] x= $rlen * $tsize->[1];
    $self;
}

sub CLEAR {
    local($self) = @_;
    $$self[0] = "\0" x ($$self[4] * $$self[3]->[1]);
    $$self[5] =  0;
    $$self[6] = -1;
}

sub FETCH {
    local($self,$key) = @_;
    local($klen, $vlen, $tsize, $rlen) = @$self[1..4];
    &hashkey;
    for (;;) {
        $offset = $hash * $rlen;
        $record = substr($$self[0], $offset, $rlen);
        if (ord($record) == 0) {
            return undef;
        }
        elsif (ord($record) == 1) {
        }
        elsif (substr($record, 1, $klen) eq $key) {
            return substr($record, 1+$klen, $vlen);
        }
        &rehash;
    }
}

sub STORE {
    local($self,$key,$val) = @_;
    local($klen, $vlen, $tsize, $rlen) = @$self[1..4];
    croak("Table is full ($tsize->[0] elements)") if $$self[5] > $tsize->[0];
    croak(qq/Value "$val" is not $vlen characters long/)
        if length($val) != $vlen;
    my $writeoffset;

    &hashkey;
    for (;;) {
        $offset = $hash * $rlen;
        $record = substr($$self[0], $offset, $rlen);
        if (ord($record) == 0) {
            $record = "\2". $key . $val;
            die "panic" unless length($record) == $rlen;
            $writeoffset = $offset unless defined $writeoffset;
            substr($$self[0], $writeoffset, $rlen) = $record;
            ++$$self[5];
            return;
        }
        elsif (ord($record) == 1) {
            $writeoffset = $offset unless defined $writeoffset;
        }
        elsif (substr($record, 1, $klen) eq $key) {
            $record = "\2". $key . $val;
            die "panic" unless length($record) == $rlen;
            substr($$self[0], $offset, $rlen) = $record;
            return;
        }
        &rehash;
    }
}

sub DELETE {
    local($self,$key) = @_;
    local($klen, $vlen, $tsize, $rlen) = @$self[1..4];
    &hashkey;
    for (;;) {
        $offset = $hash * $rlen;
        $record = substr($$self[0], $offset, $rlen);
        if (ord($record) == 0) {
            return undef;
        }
        elsif (ord($record) == 1) {
        }
        elsif (substr($record, 1, $klen) eq $key) {
            substr($$self[0], $offset, 1) = "\1";
            return substr($record, 1+$klen, $vlen);
            --$$self[5];
        }
        &rehash;
    }
}

sub FIRSTKEY {
    local($self) = @_;
    $$self[6] = -1;
    &NEXTKEY;
}

sub NEXTKEY {
    local($self) = @_;
    local($klen, $vlen, $tsize, $rlen, $entries, $iterix) = @$self[1..6];
    for (++$iterix; $iterix < $tsize->[1]; ++$iterix) {
        next unless substr($$self[0], $iterix * $rlen, 1) eq "\2";
        $$self[6] = $iterix;
        return substr($$self[0], $iterix * $rlen + 1, $klen);
    }
    $$self[6] = -1;
    undef;
}

sub EXISTS {
    croak "Tie::SubstrHash does not support exists()";
}

sub hashkey {
    croak(qq/Key "$key" is not $klen characters long/)
        if length($key) != $klen;
    $hash = 2;
    for (unpack('C*', $key)) {
        $hash = $hash * 33 + $_;
        &_hashwrap if $hash >= 1e13;
    }
    &_hashwrap if $hash >= $tsize->[1];
    $hash = 1 unless $hash;
    $hashbase = $hash;
}

sub _hashwrap {
    $hash -= int($hash / $tsize->[1]) * $tsize->[1];
}

sub rehash {
    $hash += $hashbase;
    $hash -= $tsize->[1] if $hash >= $tsize->[1];
}

# using POSIX::ceil() would be too heavy, and not all platforms have it.
sub ceil {
    my $num = shift;
    $num = int($num + 1) unless $num == int $num;
    return $num;
}

# See:
#
# http://www-groups.dcs.st-andrews.ac.uk/~history/HistTopics/Prime_numbers.html
#

sub findgteprime { # find the smallest prime integer greater than or equal to
    use integer;

    my $num = ceil(shift);
    return 2 if $num <= 2;

    $num++ unless $num % 2;
    my $i;
    my $sqrtnum = int sqrt $num;
    my $sqrtnumsquared = $sqrtnum * $sqrtnum;

  NUM:
    for (;; $num += 2) {
        if ($sqrtnumsquared < $num) {
            $sqrtnum++;
            $sqrtnumsquared = $sqrtnum * $sqrtnum;
        }
        for ($i = 3; $i <= $sqrtnum; $i += 2) {
            next NUM unless $num % $i;
        }
        return $num;
    }
}

1;
Revision:	1.1
Committed:	Thu Jun 30 14:27:16 2005 UTC (21 years, 4 months ago) by root
Branch:	MAIN
CVS Tags:	PERL-5-8-7, HEAD
Branch point for:	PERL
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.1	package Tie::SubstrHash;
2
3			our $VERSION = '1.00';
4
5			=head1 NAME
6
7			Tie::SubstrHash - Fixed-table-size, fixed-key-length hashing
8
9			=head1 SYNOPSIS
10
11			require Tie::SubstrHash;
12
13			tie %myhash, 'Tie::SubstrHash', $key_len, $value_len, $table_size;
14
15			=head1 DESCRIPTION
16
17			The B<Tie::SubstrHash> package provides a hash-table-like interface to
18			an array of determinate size, with constant key size and record size.
19
20			Upon tying a new hash to this package, the developer must specify the
21			size of the keys that will be used, the size of the value fields that the
22			keys will index, and the size of the overall table (in terms of key-value
23			pairs, not size in hard memory). I<These values will not change for the
24			duration of the tied hash>. The newly-allocated hash table may now have
25			data stored and retrieved. Efforts to store more than C<$table_size>
26			elements will result in a fatal error, as will efforts to store a value
27			not exactly C<$value_len> characters in length, or reference through a
28			key not exactly C<$key_len> characters in length. While these constraints
29			may seem excessive, the result is a hash table using much less internal
30			memory than an equivalent freely-allocated hash table.
31
32			=head1 CAVEATS
33
34			Because the current implementation uses the table and key sizes for the
35			hashing algorithm, there is no means by which to dynamically change the
36			value of any of the initialization parameters.
37
38			The hash does not support exists().
39
40			=cut
41
42			use Carp;
43
44			sub TIEHASH {
45			my $pack = shift;
46			my ($klen, $vlen, $tsize) = @_;
47			my $rlen = 1 + $klen + $vlen;
48			$tsize = [$tsize,
49			findgteprime($tsize * 1.1)]; # Allow 10% empty.
50			local $self = bless ["\0", $klen, $vlen, $tsize, $rlen, 0, -1];
51			$$self[0] x= $rlen * $tsize->[1];
52			$self;
53			}
54
55			sub CLEAR {
56			local($self) = @_;
57			$$self[0] = "\0" x ($$self[4] * $$self[3]->[1]);
58			$$self[5] = 0;
59			$$self[6] = -1;
60			}
61
62			sub FETCH {
63			local($self,$key) = @_;
64			local($klen, $vlen, $tsize, $rlen) = @$self[1..4];
65			&hashkey;
66			for (;;) {
67			$offset = $hash * $rlen;
68			$record = substr($$self[0], $offset, $rlen);
69			if (ord($record) == 0) {
70			return undef;
71			}
72			elsif (ord($record) == 1) {
73			}
74			elsif (substr($record, 1, $klen) eq $key) {
75			return substr($record, 1+$klen, $vlen);
76			}
77			&rehash;
78			}
79			}
80
81			sub STORE {
82			local($self,$key,$val) = @_;
83			local($klen, $vlen, $tsize, $rlen) = @$self[1..4];
84			croak("Table is full ($tsize->[0] elements)") if $$self[5] > $tsize->[0];
85			croak(qq/Value "$val" is not $vlen characters long/)
86			if length($val) != $vlen;
87			my $writeoffset;
88
89			&hashkey;
90			for (;;) {
91			$offset = $hash * $rlen;
92			$record = substr($$self[0], $offset, $rlen);
93			if (ord($record) == 0) {
94			$record = "\2". $key . $val;
95			die "panic" unless length($record) == $rlen;
96			$writeoffset = $offset unless defined $writeoffset;
97			substr($$self[0], $writeoffset, $rlen) = $record;
98			++$$self[5];
99			return;
100			}
101			elsif (ord($record) == 1) {
102			$writeoffset = $offset unless defined $writeoffset;
103			}
104			elsif (substr($record, 1, $klen) eq $key) {
105			$record = "\2". $key . $val;
106			die "panic" unless length($record) == $rlen;
107			substr($$self[0], $offset, $rlen) = $record;
108			return;
109			}
110			&rehash;
111			}
112			}
113
114			sub DELETE {
115			local($self,$key) = @_;
116			local($klen, $vlen, $tsize, $rlen) = @$self[1..4];
117			&hashkey;
118			for (;;) {
119			$offset = $hash * $rlen;
120			$record = substr($$self[0], $offset, $rlen);
121			if (ord($record) == 0) {
122			return undef;
123			}
124			elsif (ord($record) == 1) {
125			}
126			elsif (substr($record, 1, $klen) eq $key) {
127			substr($$self[0], $offset, 1) = "\1";
128			return substr($record, 1+$klen, $vlen);
129			--$$self[5];
130			}
131			&rehash;
132			}
133			}
134
135			sub FIRSTKEY {
136			local($self) = @_;
137			$$self[6] = -1;
138			&NEXTKEY;
139			}
140
141			sub NEXTKEY {
142			local($self) = @_;
143			local($klen, $vlen, $tsize, $rlen, $entries, $iterix) = @$self[1..6];
144			for (++$iterix; $iterix < $tsize->[1]; ++$iterix) {
145			next unless substr($$self[0], $iterix * $rlen, 1) eq "\2";
146			$$self[6] = $iterix;
147			return substr($$self[0], $iterix * $rlen + 1, $klen);
148			}
149			$$self[6] = -1;
150			undef;
151			}
152
153			sub EXISTS {
154			croak "Tie::SubstrHash does not support exists()";
155			}
156
157			sub hashkey {
158			croak(qq/Key "$key" is not $klen characters long/)
159			if length($key) != $klen;
160			$hash = 2;
161			for (unpack('C*', $key)) {
162			$hash = $hash * 33 + $_;
163			&_hashwrap if $hash >= 1e13;
164			}
165			&_hashwrap if $hash >= $tsize->[1];
166			$hash = 1 unless $hash;
167			$hashbase = $hash;
168			}
169
170			sub _hashwrap {
171			$hash -= int($hash / $tsize->[1]) * $tsize->[1];
172			}
173
174			sub rehash {
175			$hash += $hashbase;
176			$hash -= $tsize->[1] if $hash >= $tsize->[1];
177			}
178
179			# using POSIX::ceil() would be too heavy, and not all platforms have it.
180			sub ceil {
181			my $num = shift;
182			$num = int($num + 1) unless $num == int $num;
183			return $num;
184			}
185
186			# See:
187			#
188			# http://www-groups.dcs.st-andrews.ac.uk/~history/HistTopics/Prime_numbers.html
189			#
190
191			sub findgteprime { # find the smallest prime integer greater than or equal to
192			use integer;
193
194			my $num = ceil(shift);
195			return 2 if $num <= 2;
196
197			$num++ unless $num % 2;
198			my $i;
199			my $sqrtnum = int sqrt $num;
200			my $sqrtnumsquared = $sqrtnum * $sqrtnum;
201
202			NUM:
203			for (;; $num += 2) {
204			if ($sqrtnumsquared < $num) {
205			$sqrtnum++;
206			$sqrtnumsquared = $sqrtnum * $sqrtnum;
207			}
208			for ($i = 3; $i <= $sqrtnum; $i += 2) {
209			next NUM unless $num % $i;
210			}
211			return $num;
212			}
213			}
214
215			1;