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

diff --git a/MANIFEST b/MANIFEST
index cfb0fdc..1b40213 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -1452,6 +1452,7 @@ t/lib/tie-splice.t        Test for Tie::Array::SPLICE
 t/lib/tie-stdarray.t   Test for Tie::StdArray
 t/lib/tie-stdhandle.t  Test for Tie::StdHandle
 t/lib/tie-stdpush.t    Test for Tie::StdArray
+t/lib/tie-substrhash.t Test for Tie::SubstrHash
 t/lib/timelocal.t      See if Time::Local works
 t/lib/trig.t           See if Math::Trig works
 t/op/64bitint.t                See if 64 bit integers work

diff --git a/lib/Tie/SubstrHash.pm b/lib/Tie/SubstrHash.pm
index 4b18a58..b8f6449 100644 (file)
--- 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) {

diff --git a/t/lib/tie-substrhash.t b/t/lib/tie-substrhash.t
new file mode 100644 (file)
index 0000000..d21ca0a
--- /dev/null
+++ b/t/lib/tie-substrhash.t
@@ -0,0 +1,99 @@
+#!/usr/bin/perl -w
+# 
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '.'; 
+    push @INC, '../lib';
+}    
+
+print "1..16\n";
+
+use strict;
+
+require Tie::SubstrHash;
+
+my %a;
+
+tie %a, 'Tie::SubstrHash', 3, 3, 3;
+
+$a{abc} = 123;
+$a{bcd} = 234;
+
+print "not " unless $a{abc} == 123;
+print "ok 1\n";
+
+print "not " unless keys %a == 2;
+print "ok 2\n";
+
+delete $a{abc};
+
+print "not " unless $a{bcd} == 234;
+print "ok 3\n";
+
+print "not " unless (values %a)[0] == 234;
+print "ok 4\n";
+
+eval { $a{abcd} = 123 };
+print "not " unless $@ =~ /Key "abcd" is not 3 characters long/;
+print "ok 5\n";
+
+eval { $a{abc} = 1234 };
+print "not " unless $@ =~ /Value "1234" is not 3 characters long/;
+print "ok 6\n";
+
+eval { $a = $a{abcd}; $a++  };
+print "not " unless $@ =~ /Key "abcd" is not 3 characters long/;
+print "ok 7\n";
+
+@a{qw(abc cde)} = qw(123 345); 
+
+print "not " unless $a{cde} == 345;
+print "ok 8\n";
+
+eval { $a{def} = 456 };
+print "not " unless $@ =~ /Table is full \(3 elements\)/;
+print "ok 9\n";
+
+%a = ();
+
+print "not " unless keys %a == 0;
+print "ok 10\n";
+
+# Tests 11..16 by Linc Madison.
+
+my $hashsize = 119;                # arbitrary values from my data
+my %test;
+tie %test, "Tie::SubstrHash", 13, 86, $hashsize;
+
+for (my $i = 1; $i <= $hashsize; $i++) {
+        my $key1 = $i + 100_000;           # fix to uniform 6-digit numbers
+        my $key2 = "abcdefg$key1";
+        $test{$key2} = ("abcdefgh" x 10) . "$key1";
+}
+
+for (my $i = 1; $i <= $hashsize; $i++) {
+        my $key1 = $i + 100_000;
+        my $key2 = "abcdefg$key1";
+       unless ($test{$key2}) {
+               print "not ";
+               last;
+       }
+}
+print "ok 11\n";
+
+print "not " unless Tie::SubstrHash::findgteprime(1) == 2;
+print "ok 12\n";
+
+print "not " unless Tie::SubstrHash::findgteprime(2) == 2;
+print "ok 13\n";
+
+print "not " unless Tie::SubstrHash::findgteprime(5.5) == 7;
+print "ok 14\n";
+
+print "not " unless Tie::SubstrHash::findgteprime(13) == 13;
+print "ok 15\n";
+
+print "not " unless Tie::SubstrHash::findgteprime(13.000001) == 17;
+print "ok 16\n";
+