Fix the problem discussed in

Subject: [ID 20001015.004] Fwd: Tie::SubstrHash -- bug & fix (all Perl versions)
Date: Mon, 16 Oct 2000 04:48:59 +0300 (EET DST) 
Message-Id: <200010160148.EAA14523@alpha.hut.fi> 

originally from Linc Madison.  Also Andreas König's comments
taken into account.  Some other problems with Tie::SubstrHash
fixed: didn't croak when the table exceeded the requested number
of entries (as documented) but instead when the number of entries
exceeded the size of the table, a croak() had an unnecessary \n,
didn't have a CLEAR method, documented that there is no exists().
Didn't fix to be strict-proof because the module uses &foo; and
dynamic scope.  Added a test script exercizing both first tamely 
the basic functionality, and then the failure cases reported by
Linc Madison.

p4raw-id: //depot/perl@7530

1 files changed, 35 insertions, 12 deletions

diff --git a/lib/Tie/SubstrHash.pm b/lib/Tie/SubstrHash.pm
index 4b18a58e12..b8f6449c2c 100644
--- a/lib/Tie/SubstrHash.pm
+++ b/lib/Tie/SubstrHash.pm
@@ -33,6 +33,8 @@ 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;
@@ -41,12 +43,20 @@ sub TIEHASH {
     my $pack = shift;
     my ($klen, $vlen, $tsize) = @_;
     my $rlen = 1 + $klen + $vlen;
-    $tsize = findprime($tsize * 1.1);	# Allow 10% empty.
+    $tsize = [$tsize,
+	      findgteprime($tsize * 1.1)]; # Allow 10% empty.
     $self = bless ["\0", $klen, $vlen, $tsize, $rlen, 0, -1];
-    $$self[0] x= $rlen * $tsize;
+    $$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];
@@ -69,8 +79,8 @@ sub FETCH {
 sub STORE {
     local($self,$key,$val) = @_;
     local($klen, $vlen, $tsize, $rlen) = @$self[1..4];
-    croak("Table is full") if $$self[5] == $tsize;
-    croak(qq/Value "$val" is not $vlen characters long./)
+    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;
 
@@ -129,7 +139,7 @@ sub FIRSTKEY {
 sub NEXTKEY {
     local($self) = @_;
     local($klen, $vlen, $tsize, $rlen, $entries, $iterix) = @$self[1..6];
-    for (++$iterix; $iterix < $tsize; ++$iterix) {
+    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);
@@ -138,35 +148,48 @@ sub NEXTKEY {
     undef;
 }
 
+sub EXISTS {
+    croak "Tie::SubstrHash does not support exists()";
+}
+
 sub hashkey {
-    croak(qq/Key "$key" is not $klen characters long.\n/)
+    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;
+    &_hashwrap if $hash >= $tsize->[1];
     $hash = 1 unless $hash;
     $hashbase = $hash;
 }
 
 sub _hashwrap {
-    $hash -= int($hash / $tsize) * $tsize;
+    $hash -= int($hash / $tsize->[1]) * $tsize->[1];
 }
 
 sub rehash {
     $hash += $hashbase;
-    $hash -= $tsize if $hash >= $tsize;
+    $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;
 }
 
-sub findprime {
+sub findgteprime { # find the smallest prime integer greater than or equal to
     use integer;
 
-    my $num = shift;
+    my $num = ceil(shift);
+    return 2 if $num <= 2;
+
     $num++ unless $num % 2;
 
-    $max = int sqrt $num;
+    my $max = int sqrt $num;
 
   NUM:
     for (;; $num += 2) {