fix off-by-one when restoring hashes [perl #73972]

Storable tries to preallocate enough space for all of the elements it's
going to receive, both for efficiency reasons and because reallocation
triggers throwing away all of the placeholders in the hash (which are
used for restricted hashes) if the hash isn't already READONLY, and
since Storable rebuilds restricted hashes by first populating all of the
placeholders and then setting it READONLY at the end, this would break
things.

Unfortunately, it was allocating just slightly less than enough space -
hashes reallocate when they hit their limit, not when they exceed it,
and so if you tried to store a restricted hash with a number of keys
right on the boundary, it would trigger a reallocation and lose all of
the allowed keys that it had just stored. This fixes the issue by
allocating the correct amount of space to ensure that reallocation
doesn't happen.

3 files changed, 26 insertions, 5 deletions

diff --git a/dist/Storable/Storable.pm b/dist/Storable/Storable.pm
index f500cbfac2..15cb6565c3 100644
--- a/dist/Storable/Storable.pm
+++ b/dist/Storable/Storable.pm
@@ -21,7 +21,7 @@ package Storable; @ISA = qw(Exporter);
 
 use vars qw($canonical $forgive_me $VERSION);
 
-$VERSION = '2.36';
+$VERSION = '2.37';
 
 BEGIN {
     if (eval { local $SIG{__DIE__}; require Log::Agent; 1 }) {
diff --git a/dist/Storable/Storable.xs b/dist/Storable/Storable.xs
index e23b54fd6a..1ac528a48a 100644
--- a/dist/Storable/Storable.xs
+++ b/dist/Storable/Storable.xs
@@ -5106,7 +5106,7 @@ static SV *retrieve_hash(pTHX_ stcxt_t *cxt, const char *cname)
 	SEEN(hv, cname, 0);		/* Will return if table not allocated properly */
 	if (len == 0)
 		return (SV *) hv;	/* No data follow if table empty */
-	hv_ksplit(hv, len);		/* pre-extend hash to save multiple splits */
+	hv_ksplit(hv, len + 1);		/* pre-extend hash to save multiple splits */
 
 	/*
 	 * Now get each key/value pair in turn...
@@ -5193,7 +5193,7 @@ static SV *retrieve_flag_hash(pTHX_ stcxt_t *cxt, const char *cname)
     SEEN(hv, cname, 0);		/* Will return if table not allocated properly */
     if (len == 0)
         return (SV *) hv;	/* No data follow if table empty */
-    hv_ksplit(hv, len);		/* pre-extend hash to save multiple splits */
+    hv_ksplit(hv, len + 1);		/* pre-extend hash to save multiple splits */
 
     /*
      * Now get each key/value pair in turn...
@@ -5512,7 +5512,7 @@ static SV *old_retrieve_hash(pTHX_ stcxt_t *cxt, const char *cname)
 	SEEN(hv, 0, 0);			/* Will return if table not allocated properly */
 	if (len == 0)
 		return (SV *) hv;	/* No data follow if table empty */
-	hv_ksplit(hv, len);		/* pre-extend hash to save multiple splits */
+	hv_ksplit(hv, len + 1);		/* pre-extend hash to save multiple splits */
 
 	/*
 	 * Now get each key/value pair in turn...
diff --git a/dist/Storable/t/restrict.t b/dist/Storable/t/restrict.t
index 65dac6ff26..a8a9d81495 100644
--- a/dist/Storable/t/restrict.t
+++ b/dist/Storable/t/restrict.t
@@ -36,7 +36,7 @@ sub BEGIN {
 
 use Storable qw(dclone freeze thaw);
 use Hash::Util qw(lock_hash unlock_value lock_keys);
-use Test::More tests => 104;
+use Test::More tests => 304;
 
 my %hash = (question => '?', answer => 42, extra => 'junk', undef => undef);
 lock_hash %hash;
@@ -118,3 +118,24 @@ for $Storable::canonical (0, 1) {
     ok eval { $$hv2{a} = 70 }, 'COWs do not become read-only';
   }
 }
+
+# [perl #73972]
+{
+    for my $n (1..100) {
+        my @keys = map { "FOO$_" } (1..$n);
+
+        my $hash1 = {};
+        lock_keys(%$hash1, @keys);
+        my $hash2 = dclone($hash1);
+
+        my $success;
+
+        $success = eval { $hash2->{$_} = 'test' for @keys; 1 };
+        my $err = $@;
+        ok($success, "can store in all of the $n restricted slots")
+            || diag("failed with $@");
+
+        $success = !eval { $hash2->{a} = 'test'; 1 };
+        ok($success, "the hash is still restricted");
+    }
+}