Re: [perl #18651] Hash::Util's lock_key() breaks hash

Message-ID: <20021202214828.GA284@Bagpuss.unfortu.net>

p4raw-id: //depot/perl@18259

diff --git a/hv.c b/hv.c
index 0d08767..7b79123 100644 (file)
--- a/hv.c
+++ b/hv.c
@@ -1855,6 +1855,7 @@ Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
        Newz(506, xhv->xhv_array /* HvARRAY(hv) */,
             PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
             char);
+    /* At start of hash, entry is NULL.  */
     if (entry)
     {
        entry = HeNEXT(entry);
@@ -1869,8 +1870,11 @@ Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
        }
     }
     while (!entry) {
+       /* OK. Come to the end of the current list.  Grab the next one.  */
+
        xhv->xhv_riter++; /* HvRITER(hv)++ */
        if (xhv->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
+           /* There is no next one.  End of the hash.  */
            xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
            break;
        }
@@ -1878,10 +1882,14 @@ Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
        entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
 
         if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
-            /* if we have an entry, but it's a placeholder, don't count it */
-            if (entry && HeVAL(entry) == &PL_sv_undef)
-                entry = 0;
-        }
+            /* If we have an entry, but it's a placeholder, don't count it.
+              Try the next.  */
+           while (entry && HeVAL(entry) == &PL_sv_undef)
+               entry = HeNEXT(entry);
+       }
+       /* Will loop again if this linked list starts NULL
+          (for HV_ITERNEXT_WANTPLACEHOLDERS)
+          or if we run through it and find only placeholders.  */
     }
 
     if (oldentry && HvLAZYDEL(hv)) {           /* was deleted earlier? */

diff --git a/lib/Hash/Util.t b/lib/Hash/Util.t
index 20efb44..248fa8e 100644 (file)
--- a/lib/Hash/Util.t
+++ b/lib/Hash/Util.t
@@ -6,7 +6,7 @@ BEGIN {
         chdir 't';
     }
 }
-use Test::More tests => 61;
+use Test::More tests => 157;
 use strict;
 
 my @Exported_Funcs;
@@ -227,3 +227,59 @@ like( $@, qr/^Attempt to access disallowed key 'I_DONT_EXIST' in a restricted ha
     is ($hash{nowt}, undef,
         "undef values should not be misunderstood as placeholders (again)");
 }
+
+{
+  # perl #18651 - tim@consultix-inc.com found a rather nasty data dependant
+  # bug whereby hash iterators could lose hash keys (and values, as the code
+  # is common) for restricted hashes.
+
+  my @keys = qw(small medium large);
+
+  # There should be no difference whether it is restricted or not
+  foreach my $lock (0, 1) {
+    # Try setting all combinations of the 3 keys
+    foreach my $usekeys (0..7) {
+      my @usekeys;
+      for my $bits (0,1,2) {
+       push @usekeys, $keys[$bits] if $usekeys & (1 << $bits);
+      }
+      my %clean = map {$_ => length $_} @usekeys;
+      my %target;
+      lock_keys ( %target, @keys ) if $lock;
+
+      while (my ($k, $v) = each %clean) {
+       $target{$k} = $v;
+      }
+
+      my $message
+       = ($lock ? 'locked' : 'not locked') . ' keys ' . join ',', @usekeys;
+
+      is (scalar keys %target, scalar keys %clean, "scalar keys for $message");
+      is (scalar values %target, scalar values %clean,
+         "scalar values for $message");
+      # Yes. All these sorts are necessary. Even for "identical hashes"
+      # Because the data dependency of the test involves two of the strings
+      # colliding on the same bucket, so the iterator order (output of keys,
+      # values, each) depends on the addition order in the hash. And locking
+      # the keys of the hash involves behind the scenes key additions.
+      is_deeply( [sort keys %target] , [sort keys %clean],
+                "list keys for $message");
+      is_deeply( [sort values %target] , [sort values %clean],
+                "list values for $message");
+
+      is_deeply( [sort %target] , [sort %clean],
+                "hash in list context for $message");
+
+      my (@clean, @target);
+      while (my ($k, $v) = each %clean) {
+       push @clean, $k, $v;
+      }
+      while (my ($k, $v) = each %target) {
+       push @target, $k, $v;
+      }
+
+      is_deeply( [sort @target] , [sort @clean],
+                "iterating with each for $message");
+    }
+  }
+}