[perl #18341] random nits in perlrequick.pod

[p5sagit/p5-mst-13.2.git] / lib / Hash / Util.t

diff --git a/lib/Hash/Util.t b/lib/Hash/Util.t
index 20efb44..ae5e7c9 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 => 155;
 use strict;
 
 my @Exported_Funcs;
@@ -74,21 +74,12 @@ $hash{locked} = 42;
 is( $hash{locked}, 42,  'unlock_value' );
 
 
-TODO: {
-#    local $TODO = 'assigning to a hash screws with locked keys';
-
+{
     my %hash = ( foo => 42, locked => 23 );
 
     lock_keys(%hash);
-    lock_value(%hash, 'locked');
     eval { %hash = ( wubble => 42 ) };  # we know this will bomb
-    like( $@, qr/^Attempt to clear a restricted hash/ );
-
-    eval { unlock_value(%hash, 'locked') }; # but this shouldn't
-    is( $@, '', 'unlock_value() after denied assignment' );
-
-    is_deeply( \%hash, { foo => 42, locked => 23 },
-                      'hash should not be altered by denied assignment' );
+    like( $@, qr/^Attempt to access disallowed key 'wubble'/ );
     unlock_keys(%hash);
 }
 
@@ -98,16 +89,14 @@ TODO: {
     lock_value(%hash, 'RO');
 
     eval { %hash = (KEY => 1) };
-    like( $@, qr/^Attempt to clear a restricted hash/ );
+    like( $@, qr/^Attempt to delete readonly key 'RO' from a restricted hash/ );
 }
 
-# TODO:  This should be allowed but it might require putting extra
-#        code into aassign.
 {
     my %hash = (KEY => 1, RO => 2);
     lock_keys(%hash);
     eval { %hash = (KEY => 1, RO => 2) };
-    like( $@, qr/^Attempt to clear a restricted hash/ );
+    is( $@, '');
 }
 
 
@@ -227,3 +216,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");
+    }
+  }
+}