Re: restricted hashes are unblessable

Message-ID: <20020413224302.GB14889@Bagpuss.unfortu.net>

The function name sucks but can't think of anything better.

p4raw-id: //depot/perl@15914

diff --git a/lib/Hash/Util.pm b/lib/Hash/Util.pm
index 528711a..a1c9e64 100644 (file)
--- a/lib/Hash/Util.pm
+++ b/lib/Hash/Util.pm
@@ -71,6 +71,7 @@ Removes the restriction on the %hash's keyset.
 sub lock_keys (\%;@) {
     my($hash, @keys) = @_;
 
+    Internals::hv_clear_placeholders %$hash;
     if( @keys ) {
         my %keys = map { ($_ => 1) } @keys;
         my %original_keys = map { ($_ => 1) } keys %$hash;

diff --git a/lib/Hash/Util.t b/lib/Hash/Util.t
index 1046e32..a42a52e 100644 (file)
--- a/lib/Hash/Util.t
+++ b/lib/Hash/Util.t
@@ -6,7 +6,7 @@ BEGIN {
         chdir 't';
     }
 }
-use Test::More tests => 45;
+use Test::More tests => 55;
 
 my @Exported_Funcs;
 BEGIN { 
@@ -168,3 +168,38 @@ TODO: {
 lock_keys(%ENV);
 eval { () = $ENV{I_DONT_EXIST} };
 like( $@, qr/^Attempt to access disallowed key 'I_DONT_EXIST' in a restricted hash/,   'locked %ENV');
+
+{
+    my %hash;
+
+    lock_keys(%hash, 'first');
+
+    is (scalar keys %hash, 0, "place holder isn't a key");
+    $hash{first} = 1;
+    is (scalar keys %hash, 1, "we now have a key");
+    delete $hash{first};
+    is (scalar keys %hash, 0, "now no key");
+
+    unlock_keys(%hash);
+
+    $hash{interregnum} = 1.5;
+    is (scalar keys %hash, 1, "key again");
+    delete $hash{interregnum};
+    is (scalar keys %hash, 0, "no key again");
+
+    lock_keys(%hash, 'second');
+
+    is (scalar keys %hash, 0, "place holder isn't a key");
+
+    eval {$hash{zeroeth} = 0};
+    like ($@,
+          qr/^Attempt to access disallowed key 'zeroeth' in a restricted hash/,
+          'locked key never mentioned before should fail');
+    eval {$hash{first} = -1};
+    like ($@,
+          qr/^Attempt to access disallowed key 'first' in a restricted hash/,
+          'previously locked place holders should also fail');
+    is (scalar keys %hash, 0, "and therefore there are no keys");
+    $hash{second} = 1;
+    is (scalar keys %hash, 1, "we now have just one key");
+}

diff --git a/universal.c b/universal.c
index 85a0916..a9cb4cc 100644 (file)
--- a/universal.c
+++ b/universal.c
@@ -169,6 +169,7 @@ XS(XS_utf8_unicode_to_native);
 XS(XS_utf8_native_to_unicode);
 XS(XS_Internals_SvREADONLY);
 XS(XS_Internals_SvREFCNT);
+XS(XS_Internals_hv_clear_placeholders);
 
 void
 Perl_boot_core_UNIVERSAL(pTHX)
@@ -187,6 +188,8 @@ Perl_boot_core_UNIVERSAL(pTHX)
     newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
     newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
     newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
+    newXSproto("Internals::hv_clear_placeholders",
+               XS_Internals_hv_clear_placeholders, file, "\\%");
 }
 
 
@@ -500,3 +503,45 @@ XS(XS_Internals_SvREFCNT)  /* This is dangerous stuff. */
     XSRETURN_UNDEF; /* Can't happen. */
 }
 
+/* Maybe this should return the number of placeholders found in scalar context,
+   and a list of them in list context.  */
+XS(XS_Internals_hv_clear_placeholders)
+{
+    dXSARGS;
+    HV *hv = (HV *) SvRV(ST(0));
+
+    /* I don't care how many parameters were passed in, but I want to avoid
+       the unused variable warning. */
+
+    items = HvPLACEHOLDERS(hv);
+
+    if (items) {
+        HE *entry;
+        I32 riter = HvRITER(hv);
+        HE *eiter = HvEITER(hv);
+        hv_iterinit(hv);
+        while (items
+               && (entry
+                   = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
+            SV *val = hv_iterval(hv, entry);
+
+            if (val == &PL_sv_undef) {
+
+                /* It seems that I have to go back in the front of the hash
+                   API to delete a hash, even though I have a HE structure
+                   pointing to the very entry I want to delete, and could hold
+                   onto the previous HE that points to it. And it's easier to
+                   go in with SVs as I can then specify the precomputed hash,
+                   and don't have fun and games with utf8 keys.  */
+                SV *key = hv_iterkeysv(entry);
+
+                hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
+                items--;
+            }
+        }
+        HvRITER(hv) = riter;
+        HvEITER(hv) = eiter;
+    }
+
+    XSRETURN(0);
+}