From: Dave Mitchell <davem@fdisolutions.com>
Date: Sat, 26 Apr 2003 18:45:28 +0000 (+0100)
Subject: Re: the revenge of the bride of the son of the night of the living pseudohashes
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=34c3c4e3c36afb477dacf54a0d4557360c741870;p=p5sagit%2Fp5-mst-13.2.git

Re: the revenge of the bride of the son of the night of the living pseudohashes
Message-ID: <20030426174528.GA9588@fdgroup.com>

p4raw-id: //depot/perl@19345
---

diff --git a/hv.c b/hv.c
index 438042b..5abfc62 100644
--- a/hv.c
+++ b/hv.c
@@ -151,7 +151,7 @@ S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen,
     }
     else {
 	/* Need to free saved eventually assign to mortal SV */
-	SV *sv = sv_newmortal();
+	/* XXX is this line an error ???:  SV *sv = sv_newmortal(); */
 	sv_usepvn(sv, (char *) key, klen);
     }
     if (flags & HVhek_UTF8) {
@@ -1701,11 +1701,32 @@ Perl_hv_clear(pTHX_ HV *hv)
     if (!hv)
 	return;
 
+    xhv = (XPVHV*)SvANY(hv);
+
     if(SvREADONLY(hv)) {
-        Perl_croak(aTHX_ "Attempt to clear a restricted hash");
+	/* restricted hash: convert all keys to placeholders */
+	I32 i;
+	HE* entry;
+	for (i=0; i< (I32) xhv->xhv_max; i++) {
+	    entry = ((HE**)xhv->xhv_array)[i];
+	    for (; entry; entry = HeNEXT(entry)) {
+		/* not already placeholder */
+		if (HeVAL(entry) != &PL_sv_undef) {
+		    if (HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
+			SV* keysv = hv_iterkeysv(entry);
+			Perl_croak(aTHX_
+		"Attempt to delete readonly key '%_' from a restricted hash",
+				keysv);
+		    }
+		    SvREFCNT_dec(HeVAL(entry));
+		    HeVAL(entry) = &PL_sv_undef;
+		    xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
+		}
+	    }
+	}
+	return;
     }
 
-    xhv = (XPVHV*)SvANY(hv);
     hfreeentries(hv);
     xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
     xhv->xhv_keys = 0; /* HvKEYS(hv) = 0 */
diff --git a/lib/Hash/Util.t b/lib/Hash/Util.t
index 248fa8e..ae5e7c9 100644
--- a/lib/Hash/Util.t
+++ b/lib/Hash/Util.t
@@ -6,7 +6,7 @@ BEGIN {
         chdir 't';
     }
 }
-use Test::More tests => 157;
+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( $@, '');
 }
 
 
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 3baec3a..8576f26 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -200,12 +200,6 @@ know which context to supply to the right side.
 (F) The failing code has attempted to get or set a key which is not in
 the current set of allowed keys of a restricted hash.
 
-=item Attempt to clear a restricted hash
-
-(F) It is currently not allowed to clear a restricted hash, even if the
-new hash would contain the same keys as before.  This may change in
-the future.
-
 =item Attempt to delete readonly key '%s' from a restricted hash
 
 (F) The failing code attempted to delete a key whose value has been