1
- package Tie::SubstrHash ;
2
-
3
- our $VERSION = ' 1.00' ;
1
+ package Tie::SubstrHash 1.01;
4
2
5
3
=head1 NAME
6
4
@@ -39,33 +37,35 @@ The hash does not support exists().
39
37
40
38
=cut
41
39
40
+ use strict;
41
+ use warnings;
42
+ no warnings ' experimental::builtin' ;
43
+
42
44
use Carp;
43
45
44
46
sub TIEHASH {
45
- my $pack = shift ;
46
- my ($klen , $vlen , $tsize ) = @_ ;
47
+ my ($pack , $klen , $vlen , $tsize ) = @_ ;
47
48
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];
49
+ $tsize = [$tsize , findgteprime($tsize * 1.1)]; # Allow 10% empty.
50
+ my $self = bless [" \0 " , $klen , $vlen , $tsize , $rlen , 0, -1];
51
51
$self -> [0] x= $rlen * $tsize -> [1];
52
52
$self ;
53
53
}
54
54
55
55
sub CLEAR {
56
- local ($self ) = @_ ;
56
+ my ($self ) = @_ ;
57
57
$self -> [0] = " \0 " x ($self -> [4] * $self -> [3][1]);
58
58
$self -> [5] = 0;
59
59
$self -> [6] = -1;
60
60
}
61
61
62
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 );
63
+ my ($self , $key ) = @_ ;
64
+ my ( undef , $klen , $vlen , $tsize , $rlen ) = @$self ;
65
+ my $hashbase = my $hash = hashkey( $key , $klen , $tsize ) ;
66
+ while (1 ) {
67
+ my $offset = $hash * $rlen ;
68
+ my $record = substr ($self -> [0], $offset , $rlen );
69
69
if (ord ($record ) == 0) {
70
70
return undef ;
71
71
}
@@ -74,22 +74,22 @@ sub FETCH {
74
74
elsif (substr ($record , 1, $klen ) eq $key ) {
75
75
return substr ($record , 1+$klen , $vlen );
76
76
}
77
- & rehash;
77
+ $hash = rehash( $hash , $hashbase , $tsize ) ;
78
78
}
79
79
}
80
80
81
81
sub STORE {
82
- local ($self ,$key ,$val ) = @_ ;
83
- local ( $klen , $vlen , $tsize , $rlen ) = @$self [1..4] ;
82
+ my ($self , $key , $val ) = @_ ;
83
+ my ( undef , $klen , $vlen , $tsize , $rlen ) = @$self ;
84
84
croak(" Table is full ($tsize ->[0] elements)" ) if $self -> [5] > $tsize -> [0];
85
85
croak(qq/ Value "$val " is not $vlen characters long/ )
86
86
if length ($val ) != $vlen ;
87
87
my $writeoffset ;
88
88
89
- & hashkey;
90
- for (;; ) {
91
- $offset = $hash * $rlen ;
92
- $record = substr ($self -> [0], $offset , $rlen );
89
+ my $hashbase = my $hash = hashkey( $key , $klen , $tsize ) ;
90
+ while (1 ) {
91
+ my $offset = $hash * $rlen ;
92
+ my $record = substr ($self -> [0], $offset , $rlen );
93
93
if (ord ($record ) == 0) {
94
94
$record = " \2 " . $key . $val ;
95
95
die " panic" unless length ($record ) == $rlen ;
@@ -107,17 +107,17 @@ sub STORE {
107
107
substr ($self -> [0], $offset , $rlen ) = $record ;
108
108
return ;
109
109
}
110
- & rehash;
110
+ $hash = rehash( $hash , $hashbase , $tsize ) ;
111
111
}
112
112
}
113
113
114
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 );
115
+ my ($self , $key ) = @_ ;
116
+ my ( undef , $klen , $vlen , $tsize , $rlen ) = @$self ;
117
+ my $hashbase = my $hash = hashkey( $key , $klen , $tsize ) ;
118
+ while (1 ) {
119
+ my $offset = $hash * $rlen ;
120
+ my $record = substr ($self -> [0], $offset , $rlen );
121
121
if (ord ($record ) == 0) {
122
122
return undef ;
123
123
}
@@ -128,19 +128,19 @@ sub DELETE {
128
128
return substr ($record , 1+$klen , $vlen );
129
129
--$self -> [5];
130
130
}
131
- & rehash;
131
+ $hash = rehash( $hash , $hashbase , $tsize ) ;
132
132
}
133
133
}
134
134
135
135
sub FIRSTKEY {
136
- local ($self ) = @_ ;
136
+ my ($self ) = @_ ;
137
137
$self -> [6] = -1;
138
- &NEXTKEY;
138
+ goto &NEXTKEY;
139
139
}
140
140
141
141
sub NEXTKEY {
142
- local ($self ) = @_ ;
143
- local ( $klen , $vlen , $tsize , $rlen , $entries , $iterix ) = @$self [1..6] ;
142
+ my ($self ) = @_ ;
143
+ my ( undef , $klen , $vlen , $tsize , $rlen , $entries , $iterix ) = @$self ;
144
144
for (++$iterix ; $iterix < $tsize -> [1]; ++$iterix ) {
145
145
next unless substr ($self -> [0], $iterix * $rlen , 1) eq " \2 " ;
146
146
$self -> [6] = $iterix ;
@@ -155,25 +155,29 @@ sub EXISTS {
155
155
}
156
156
157
157
sub hashkey {
158
+ my ($key , $klen , $tsize ) = @_ ;
158
159
croak(qq/ Key "$key " is not $klen characters long/ )
159
160
if length ($key ) != $klen ;
160
- $hash = 2;
161
+ my $hash = 2;
161
162
for (unpack (' C*' , $key )) {
162
163
$hash = $hash * 33 + $_ ;
163
- & _hashwrap if $hash >= 1e13;
164
+ $hash = _hashwrap( $hash , $tsize ) if $hash >= 1e13;
164
165
}
165
- & _hashwrap if $hash >= $tsize -> [1];
166
+ $hash = _hashwrap( $hash , $tsize ) if $hash >= $tsize -> [1];
166
167
$hash ||= 1;
167
- $hashbase = $hash ;
168
+ return $hash ;
168
169
}
169
170
170
171
sub _hashwrap {
171
- $hash -= int ($hash / $tsize -> [1]) * $tsize -> [1];
172
+ my ($hash , $tsize ) = @_ ;
173
+ return $hash - int ($hash / $tsize -> [1]) * $tsize -> [1];
172
174
}
173
175
174
176
sub rehash {
177
+ my ($hash , $hashbase , $tsize ) = @_ ;
175
178
$hash += $hashbase ;
176
179
$hash -= $tsize -> [1] if $hash >= $tsize -> [1];
180
+ return $hash ;
177
181
}
178
182
179
183
# See:
@@ -188,7 +192,6 @@ sub findgteprime { # find the smallest prime integer greater than or equal to
188
192
return 2 if $num <= 2;
189
193
190
194
$num ++ unless $num % 2;
191
- my $i ;
192
195
my $sqrtnum = int sqrt $num ;
193
196
my $sqrtnumsquared = $sqrtnum * $sqrtnum ;
194
197
@@ -198,7 +201,7 @@ sub findgteprime { # find the smallest prime integer greater than or equal to
198
201
$sqrtnum ++;
199
202
$sqrtnumsquared = $sqrtnum * $sqrtnum ;
200
203
}
201
- for ($i = 3; $i <= $sqrtnum ; $i += 2) {
204
+ for (my $i = 3; $i <= $sqrtnum ; $i += 2) {
202
205
next NUM unless $num % $i ;
203
206
}
204
207
return $num ;
0 commit comments