This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Test-Harness breaks libwww-perl, Sorry
[perl5.git] / lib / Tie / SubstrHash.pm
CommitLineData
748a9306
LW
1package SubstrHash;
2use Carp;
3
4sub 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
14sub 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
33sub 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
66sub 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
87sub FIRSTKEY {
88 local($self) = @_;
89 $$self[6] = -1;
90 &NEXTKEY;
91}
92
93sub 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
105sub 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
118sub rehash {
119 $hash += $hashbase;
120 $hash -= $tsize if $hash >= $tsize;
121}
122
123sub 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
1401;