Tidied version of Jeffrey Friedl's <jfriedl@yahoo.com> restricted hashes

 - added delete of READONLY value inhibit & test for same
 - re-tabbed

p4raw-id: //depot/perlio@13760

diff --git a/ext/Devel/Peek/Peek.t b/ext/Devel/Peek/Peek.t
index 4062461..9be948c 100644 (file)
--- a/ext/Devel/Peek/Peek.t
+++ b/ext/Devel/Peek/Peek.t
@@ -27,6 +27,7 @@ sub do_test {
        if (open(IN, "peek$$")) {
            local $/;
            $pattern =~ s/\$ADDR/0x[[:xdigit:]]+/g;
+           $pattern =~ s/\$FLOAT/(?:\\d*\\.\\d+(?:e[-+]\\d+)?|\\d+)/g;
            print $pattern, "\n" if $DEBUG;
            my $dump = <IN>;
            print $dump, "\n"    if $DEBUG;
@@ -187,7 +188,7 @@ do_test(12,
     REFCNT = 2
     FLAGS = \\(SHAREKEYS\\)
     IV = 1
-    NV = 0
+    NV = $FLOAT
     ARRAY = $ADDR  \\(0:7, 1:1\\)
     hash quality = 100.0%
     KEYS = 1
@@ -348,7 +349,7 @@ do_test(19,
     REFCNT = 2
     FLAGS = \\(SHAREKEYS\\)
     IV = 1
-    NV = 0
+    NV = $FLOAT
     ARRAY = $ADDR  \\(0:7, 1:1\\)
     hash quality = 100.0%
     KEYS = 1

diff --git a/hv.c b/hv.c
index 5d7b49f..05f6deb 100644 (file)
--- a/hv.c
+++ b/hv.c
@@ -21,7 +21,7 @@ S_new_he(pTHX)
     HE* he;
     LOCK_SV_MUTEX;
     if (!PL_he_root)
-        more_he();
+       more_he();
     he = PL_he_root;
     PL_he_root = HeNEXT(he);
     UNLOCK_SV_MUTEX;
@@ -51,8 +51,8 @@ S_more_he(pTHX)
     heend = &he[1008 / sizeof(HE) - 1];
     PL_he_root = ++he;
     while (he < heend) {
-        HeNEXT(he) = (HE*)(he + 1);
-        he++;
+       HeNEXT(he) = (HE*)(he + 1);
+       he++;
     }
     HeNEXT(he) = 0;
 }
@@ -208,9 +208,9 @@ Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen, I32 lval)
     if (!xhv->xhv_array /* !HvARRAY(hv) */) {
        if (lval
 #ifdef DYNAMIC_ENV_FETCH  /* if it's an %ENV lookup, we may get it on the fly */
-                || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
+                || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
 #endif
-                                                                 )
+                                                                 )
            Newz(503, xhv->xhv_array /* HvARRAY(hv) */,
                 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
                 char);
@@ -241,7 +241,11 @@ Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen, I32 lval)
            continue;
        if (key != keysave)
            Safefree(key);
+       /* if we find a placeholder, we pretend we haven't found anything */
+       if (HeVAL(entry) == &PL_sv_undef)
+           break;
        return &HeVAL(entry);
+
     }
 #ifdef DYNAMIC_ENV_FETCH  /* %ENV lookup?  If so, try to fetch the value now */
     if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
@@ -256,7 +260,7 @@ Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen, I32 lval)
        }
     }
 #endif
-    if (SvREADONLY(hv)) {
+    if (!entry && SvREADONLY(hv)) {
        Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave);
     }
     if (lval) {                /* gonna assign to this, so it better be there */
@@ -342,9 +346,9 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
     if (!xhv->xhv_array /* !HvARRAY(hv) */) {
        if (lval
 #ifdef DYNAMIC_ENV_FETCH  /* if it's an %ENV lookup, we may get it on the fly */
-                || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
+                || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
 #endif
-                                                                 )
+                                                                 )
            Newz(503, xhv->xhv_array /* HvARRAY(hv) */,
                 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
                 char);
@@ -374,6 +378,9 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
            continue;
        if (key != keysave)
            Safefree(key);
+       /* if we find a placeholder, we pretend we haven't found anything */
+       if (HeVAL(entry) == &PL_sv_undef)
+           break;
        return entry;
     }
 #ifdef DYNAMIC_ENV_FETCH  /* %ENV lookup?  If so, try to fetch the value now */
@@ -387,7 +394,7 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
        }
     }
 #endif
-    if (SvREADONLY(hv)) {
+    if (!entry && SvREADONLY(hv)) {
        Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave);
     }
     if (key != keysave)
@@ -465,7 +472,7 @@ Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, register U32 has
                return 0;
 #ifdef ENV_IS_CASELESS
            else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
-                key = savepvn(key,klen);
+               key = savepvn(key,klen);
                key = (const char*)strupr((char*)key);
                hash = 0;
            }
@@ -500,7 +507,10 @@ Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, register U32 has
            continue;
        if (HeKUTF8(entry) != (char)is_utf8)
            continue;
-       SvREFCNT_dec(HeVAL(entry));
+       if (HeVAL(entry) == &PL_sv_undef)
+           xhv->xhv_placeholders--; /* yes, can store into placeholder slot */
+       else
+           SvREFCNT_dec(HeVAL(entry));
        HeVAL(entry) = val;
        if (key != keysave)
            Safefree(key);
@@ -568,18 +578,18 @@ Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash)
 
     xhv = (XPVHV*)SvANY(hv);
     if (SvMAGICAL(hv)) {
-       bool needs_copy;
-       bool needs_store;
-       hv_magic_check (hv, &needs_copy, &needs_store);
-       if (needs_copy) {
-           bool save_taint = PL_tainted;
-           if (PL_tainting)
-               PL_tainted = SvTAINTED(keysv);
-           keysv = sv_2mortal(newSVsv(keysv));
-           mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
-           TAINT_IF(save_taint);
-           if (!xhv->xhv_array /* !HvARRAY(hv) */ && !needs_store)
-               return Nullhe;
+       bool needs_copy;
+       bool needs_store;
+       hv_magic_check (hv, &needs_copy, &needs_store);
+       if (needs_copy) {
+           bool save_taint = PL_tainted;
+           if (PL_tainting)
+               PL_tainted = SvTAINTED(keysv);
+           keysv = sv_2mortal(newSVsv(keysv));
+           mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
+           TAINT_IF(save_taint);
+           if (!xhv->xhv_array /* !HvARRAY(hv) */ && !needs_store)
+               return Nullhe;
 #ifdef ENV_IS_CASELESS
            else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
                key = SvPV(keysv, klen);
@@ -618,7 +628,10 @@ Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash)
            continue;
        if (HeKUTF8(entry) != (char)is_utf8)
            continue;
-       SvREFCNT_dec(HeVAL(entry));
+       if (HeVAL(entry) == &PL_sv_undef)
+           xhv->xhv_placeholders--; /* yes, can store into placeholder slot */
+       else
+           SvREFCNT_dec(HeVAL(entry));
        HeVAL(entry) = val;
        if (key != keysave)
            Safefree(key);
@@ -702,7 +715,7 @@ Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags)
                key = strupr(SvPVX(sv));
            }
 #endif
-        }
+       }
     }
     xhv = (XPVHV*)SvANY(hv);
     if (!xhv->xhv_array /* !HvARRAY(hv) */)
@@ -715,10 +728,6 @@ Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags)
        klen = tmplen;
     }
 
-    if (SvREADONLY(hv)) {
-       Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave);
-    }
-
     PERL_HASH(hash, key, klen);
 
     /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
@@ -736,6 +745,29 @@ Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags)
            continue;
        if (key != keysave)
            Safefree(key);
+       /* if placeholder is here, it's already been deleted.... */
+       if (HeVAL(entry) == &PL_sv_undef)
+       {
+           if (SvREADONLY(hv))
+               return Nullsv;  /* if still SvREADONLY, leave it deleted. */
+           else {
+               /* okay, really delete the placeholder... */
+               *oentry = HeNEXT(entry);
+               if (i && !*oentry)
+                   xhv->xhv_fill--; /* HvFILL(hv)-- */
+               if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
+                   HvLAZYDEL_on(hv);
+               else
+                   hv_free_ent(hv, entry);
+               xhv->xhv_keys--; /* HvKEYS(hv)-- */
+               xhv->xhv_placeholders--;
+               return Nullsv;
+           }
+       }
+       else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
+           Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave);
+       }
+
        *oentry = HeNEXT(entry);
        if (i && !*oentry)
            xhv->xhv_fill--; /* HvFILL(hv)-- */
@@ -745,13 +777,31 @@ Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags)
            sv = sv_2mortal(HeVAL(entry));
            HeVAL(entry) = &PL_sv_undef;
        }
-       if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
-           HvLAZYDEL_on(hv);
-       else
-           hv_free_ent(hv, entry);
-       xhv->xhv_keys--; /* HvKEYS(hv)-- */
+
+       /*
+        * If a restricted hash, rather than really deleting the entry, put
+        * a placeholder there. This marks the key as being "approved", so
+        * we can still access via not-really-existing key without raising
+        * an error.
+        */
+       if (SvREADONLY(hv)) {
+           HeVAL(entry) = &PL_sv_undef;
+           /* We'll be saving this slot, so the number of allocated keys
+            * doesn't go down, but the number placeholders goes up */
+           xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
+       } else {
+           if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
+               HvLAZYDEL_on(hv);
+           else
+               hv_free_ent(hv, entry);
+           xhv->xhv_keys--; /* HvKEYS(hv)-- */
+       }
        return sv;
     }
+    if (SvREADONLY(hv)) {
+       Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave);
+    }
+
     if (key != keysave)
        Safefree(key);
     return Nullsv;
@@ -819,10 +869,6 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
     if (is_utf8)
        key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
 
-    if (SvREADONLY(hv)) {
-       Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave);
-    }
-
     if (!hash)
        PERL_HASH(hash, key, klen);
 
@@ -841,6 +887,30 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
            continue;
        if (key != keysave)
            Safefree(key);
+
+       /* if placeholder is here, it's already been deleted.... */
+       if (HeVAL(entry) == &PL_sv_undef)
+       {
+           if (SvREADONLY(hv))
+               return Nullsv; /* if still SvREADONLY, leave it deleted. */
+           else {
+               // okay, really delete the placeholder.
+               *oentry = HeNEXT(entry);
+               if (i && !*oentry)
+                   xhv->xhv_fill--; /* HvFILL(hv)-- */
+               if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
+                   HvLAZYDEL_on(hv);
+               else
+                   hv_free_ent(hv, entry);
+               xhv->xhv_keys--; /* HvKEYS(hv)-- */
+               xhv->xhv_placeholders--;
+               return Nullsv;
+           }
+       }
+       else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
+           Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave);
+       }
+
        *oentry = HeNEXT(entry);
        if (i && !*oentry)
            xhv->xhv_fill--; /* HvFILL(hv)-- */
@@ -850,13 +920,31 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
            sv = sv_2mortal(HeVAL(entry));
            HeVAL(entry) = &PL_sv_undef;
        }
-       if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
-           HvLAZYDEL_on(hv);
-       else
-           hv_free_ent(hv, entry);
-       xhv->xhv_keys--; /* HvKEYS(hv)-- */
+
+       /*
+        * If a restricted hash, rather than really deleting the entry, put
+        * a placeholder there. This marks the key as being "approved", so
+        * we can still access via not-really-existing key without raising
+        * an error.
+        */
+       if (SvREADONLY(hv)) {
+           HeVAL(entry) = &PL_sv_undef;
+           /* We'll be saving this slot, so the number of allocated keys
+            * doesn't go down, but the number placeholders goes up */
+           xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
+       } else {
+           if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
+               HvLAZYDEL_on(hv);
+           else
+               hv_free_ent(hv, entry);
+           xhv->xhv_keys--; /* HvKEYS(hv)-- */
+       }
        return sv;
     }
+    if (SvREADONLY(hv)) {
+       Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave);
+    }
+
     if (key != keysave)
        Safefree(key);
     return Nullsv;
@@ -936,6 +1024,10 @@ Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen)
            continue;
        if (key != keysave)
            Safefree(key);
+       /* If we find the key, but the value is a placeholder, return false. */
+       if (HeVAL(entry) == &PL_sv_undef)
+           return FALSE;
+
        return TRUE;
     }
 #ifdef DYNAMIC_ENV_FETCH  /* is it out there? */
@@ -982,12 +1074,12 @@ Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
 
     if (SvRMAGICAL(hv)) {
        if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
-           SV* svret = sv_newmortal();
+          SV* svret = sv_newmortal();
            sv = sv_newmortal();
            keysv = sv_2mortal(newSVsv(keysv));
            mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
-           magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
-           return SvTRUE(svret);
+          magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
+          return SvTRUE(svret);
        }
 #ifdef ENV_IS_CASELESS
        else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
@@ -1029,6 +1121,9 @@ Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
            continue;
        if (key != keysave)
            Safefree(key);
+       /* If we find the key, but the value is a placeholder, return false. */
+       if (HeVAL(entry) == &PL_sv_undef)
+           return FALSE;
        return TRUE;
     }
 #ifdef DYNAMIC_ENV_FETCH  /* is it out there? */
@@ -1139,13 +1234,13 @@ Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
        PL_nomemok = TRUE;
 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
        Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
-        if (!a) {
+       if (!a) {
          PL_nomemok = FALSE;
          return;
        }
 #else
        New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
-        if (!a) {
+       if (!a) {
          PL_nomemok = FALSE;
          return;
        }
@@ -1266,7 +1361,7 @@ Perl_newHVhv(pTHX_ HV *ohv)
 
        HvMAX(hv)   = hv_max;
        HvFILL(hv)  = hv_fill;
-       HvKEYS(hv)  = HvKEYS(ohv);
+       HvTOTALKEYS(hv)  = HvTOTALKEYS(ohv);
        HvARRAY(hv) = ents;
     }
     else {
@@ -1305,7 +1400,7 @@ Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
     SvREFCNT_dec(val);
     if (HeKLEN(entry) == HEf_SVKEY) {
        SvREFCNT_dec(HeKEY_sv(entry));
-        Safefree(HeKEY_hek(entry));
+       Safefree(HeKEY_hek(entry));
     }
     else if (HvSHAREKEYS(hv))
        unshare_hek(HeKEY_hek(entry));
@@ -1351,6 +1446,7 @@ Perl_hv_clear(pTHX_ HV *hv)
     hfreeentries(hv);
     xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
     xhv->xhv_keys = 0; /* HvKEYS(hv) = 0 */
+    xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
     if (xhv->xhv_array /* HvARRAY(hv) */)
        (void)memzero(xhv->xhv_array /* HvARRAY(hv) */,
                      (xhv->xhv_max+1 /* HvMAX(hv)+1 */) * sizeof(HE*));
@@ -1417,6 +1513,7 @@ Perl_hv_undef(pTHX_ HV *hv)
     xhv->xhv_array = 0;        /* HvARRAY(hv) = 0 */
     xhv->xhv_fill  = 0;        /* HvFILL(hv) = 0 */
     xhv->xhv_keys  = 0;        /* HvKEYS(hv) = 0 */
+    xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
 
     if (SvRMAGICAL(hv))
        mg_clear((SV*)hv);
@@ -1453,7 +1550,7 @@ Perl_hv_iterinit(pTHX_ HV *hv)
     xhv->xhv_riter = -1;       /* HvRITER(hv) = -1 */
     xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
     /* used to be xhv->xhv_fill before 5.004_65 */
-    return xhv->xhv_keys; /* HvKEYS(hv) */
+    return XHvTOTALKEYS(xhv);
 }
 
 /*
@@ -1496,11 +1593,11 @@ Perl_hv_iternext(pTHX_ HV *hv)
            HeKLEN(entry) = HEf_SVKEY;
        }
        magic_nextpack((SV*) hv,mg,key);
-        if (SvOK(key)) {
+       if (SvOK(key)) {
            /* force key to stay around until next time */
            HeSVKEY_set(entry, SvREFCNT_inc(key));
            return entry;               /* beware, hent_val is not set */
-        }
+       }
        if (HeVAL(entry))
            SvREFCNT_dec(HeVAL(entry));
        Safefree(HeKEY_hek(entry));
@@ -1518,7 +1615,16 @@ Perl_hv_iternext(pTHX_ HV *hv)
             PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
             char);
     if (entry)
+    {
        entry = HeNEXT(entry);
+       /*
+        * Skip past any placeholders -- don't want to include them in
+        * any iteration.
+        */
+       while (entry && HeVAL(entry) == &PL_sv_undef) {
+           entry = HeNEXT(entry);
+       }
+    }
     while (!entry) {
        xhv->xhv_riter++; /* HvRITER(hv)++ */
        if (xhv->xhv_riter > xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
@@ -1527,6 +1633,11 @@ Perl_hv_iternext(pTHX_ HV *hv)
        }
        /* entry = (HvARRAY(hv))[HvRITER(hv)]; */
        entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
+
+       /* if we have an entry, but it's a placeholder, don't count it */
+       if (entry && HeVAL(entry) == &PL_sv_undef)
+           entry = 0;
+
     }
 
     if (oldentry && HvLAZYDEL(hv)) {           /* was deleted earlier? */
@@ -1735,7 +1846,7 @@ Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
     /* what follows is the moral equivalent of:
 
     if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
-       hv_store(PL_strtab, str, len, Nullsv, hash);
+       hv_store(PL_strtab, str, len, Nullsv, hash);
     */
     xhv = (XPVHV*)SvANY(PL_strtab);
     /* assert(xhv_array != 0) */

diff --git a/hv.h b/hv.h
index 3475c87..f99bc7d 100644 (file)
--- a/hv.h
+++ b/hv.h
@@ -33,6 +33,7 @@ struct xpvhv {
     STRLEN     xhv_max;        /* subscript of last element of xhv_array */
     IV         xhv_keys;       /* how many elements in the array */
     NV         xnv_nv;         /* numeric value, if any */
+#define xhv_placeholders xnv_nv
     MAGIC*     xmg_magic;      /* magic for scalar array */
     HV*                xmg_stash;      /* class package */
 
@@ -126,12 +127,31 @@ C<SV*>.
 #define HvARRAY(hv)    (*(HE***)&((XPVHV*)  SvANY(hv))->xhv_array)
 #define HvFILL(hv)     ((XPVHV*)  SvANY(hv))->xhv_fill
 #define HvMAX(hv)      ((XPVHV*)  SvANY(hv))->xhv_max
-#define HvKEYS(hv)     ((XPVHV*)  SvANY(hv))->xhv_keys
 #define HvRITER(hv)    ((XPVHV*)  SvANY(hv))->xhv_riter
 #define HvEITER(hv)    ((XPVHV*)  SvANY(hv))->xhv_eiter
 #define HvPMROOT(hv)   ((XPVHV*)  SvANY(hv))->xhv_pmroot
 #define HvNAME(hv)     ((XPVHV*)  SvANY(hv))->xhv_name
 
+/* the number of keys (including any placeholers) */
+#define XHvTOTALKEYS(xhv)      ((xhv)->xhv_keys)
+
+/* The number of placeholders in the enumerated-keys hash */
+#define XHvPLACEHOLDERS(xhv)   ((IV)((xhv)->xhv_placeholders))
+
+/* the number of keys that exist() (i.e. excluding placeholers) */
+#define XHvUSEDKEYS(xhv)      (XHvTOTALKEYS(xhv) - XHvPLACEHOLDERS(xhv))
+
+/*
+ * HvKEYS gets the number of keys that actually exist(), and is provided
+ * for backwards compatibility with old XS code. The core uses HvUSEDKEYS
+ * (keys, excluding placeholdes) and HvTOTALKEYS (including placeholders)
+ */
+#define HvKEYS(hv)             XHvUSEDKEYS((XPVHV*)  SvANY(hv))
+#define HvUSEDKEYS(hv)         XHvUSEDKEYS((XPVHV*)  SvANY(hv))
+#define HvTOTALKEYS(hv)                XHvTOTALKEYS((XPVHV*)  SvANY(hv))
+#define HvPLACEHOLDERS(hv)     XHvPLACEHOLDERS((XPVHV*)  SvANY(hv))
+
+
 #define HvSHAREKEYS(hv)                (SvFLAGS(hv) & SVphv_SHAREKEYS)
 #define HvSHAREKEYS_on(hv)     (SvFLAGS(hv) |= SVphv_SHAREKEYS)
 #define HvSHAREKEYS_off(hv)    (SvFLAGS(hv) &= ~SVphv_SHAREKEYS)

diff --git a/scope.c b/scope.c
index cc6f13c..da5fa6b 100644 (file)
--- a/scope.c
+++ b/scope.c
@@ -143,7 +143,7 @@ Perl_markstack_grow(pTHX)
 void
 Perl_savestack_grow(pTHX)
 {
-    PL_savestack_max = GROW(PL_savestack_max) + 4; 
+    PL_savestack_max = GROW(PL_savestack_max) + 4;
     Renew(PL_savestack, PL_savestack_max, ANY);
 }
 
@@ -169,7 +169,7 @@ Perl_free_tmps(pTHX)
     while (PL_tmps_ix > myfloor) {      /* clean up after last statement */
        SV* sv = PL_tmps_stack[PL_tmps_ix];
        PL_tmps_stack[PL_tmps_ix--] = Nullsv;
-       if (sv) {
+       if (sv && sv != &PL_sv_undef) {
            SvTEMP_off(sv);
            SvREFCNT_dec(sv);           /* note, can modify tmps_ix!!! */
        }
@@ -195,7 +195,7 @@ S_save_scalar_at(pTHX_ SV **sptr)
                mg->mg_obj = osv;
            }
            SvFLAGS(osv) |= (SvFLAGS(osv) &
-               (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
+              (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
            PL_tainted = oldtainted;
        }
        SvMAGIC(sv) = SvMAGIC(osv);
@@ -606,12 +606,12 @@ I32
 Perl_save_alloc(pTHX_ I32 size, I32 pad)
 {
     register I32 start = pad + ((char*)&PL_savestack[PL_savestack_ix]
-                                - (char*)PL_savestack);
+                               - (char*)PL_savestack);
     register I32 elems = 1 + ((size + pad - 1) / sizeof(*PL_savestack));
 
     /* SSCHECK may not be good enough */
     while (PL_savestack_ix + elems + 2 > PL_savestack_max)
-        savestack_grow();
+       savestack_grow();
 
     PL_savestack_ix += elems;
     SSPUSHINT(elems);
@@ -643,13 +643,13 @@ Perl_leave_scope(pTHX_ I32 base)
            SvSETMAGIC(sv);
            PL_localizing = 0;
            break;
-        case SAVEt_SV:                         /* scalar reference */
+       case SAVEt_SV:                          /* scalar reference */
            value = (SV*)SSPOPPTR;
            gv = (GV*)SSPOPPTR;
            ptr = &GvSV(gv);
            SvREFCNT_dec(gv);
            goto restore_sv;
-        case SAVEt_GENERIC_PVREF:              /* generic pv */
+       case SAVEt_GENERIC_PVREF:               /* generic pv */
            str = (char*)SSPOPPTR;
            ptr = SSPOPPTR;
            if (*(char**)ptr != str) {
@@ -657,7 +657,7 @@ Perl_leave_scope(pTHX_ I32 base)
                *(char**)ptr = str;
            }
            break;
-        case SAVEt_GENERIC_SVREF:              /* generic sv */
+       case SAVEt_GENERIC_SVREF:               /* generic sv */
            value = (SV*)SSPOPPTR;
            ptr = SSPOPPTR;
            sv = *(SV**)ptr;
@@ -665,14 +665,14 @@ Perl_leave_scope(pTHX_ I32 base)
            SvREFCNT_dec(sv);
            SvREFCNT_dec(value);
            break;
-        case SAVEt_SVREF:                      /* scalar reference */
+       case SAVEt_SVREF:                       /* scalar reference */
            value = (SV*)SSPOPPTR;
            ptr = SSPOPPTR;
        restore_sv:
            sv = *(SV**)ptr;
            DEBUG_S(PerlIO_printf(Perl_debug_log,
                                  "restore svref: %p %p:%s -> %p:%s\n",
-                                 ptr, sv, SvPEEK(sv), value, SvPEEK(value)));
+                                 ptr, sv, SvPEEK(sv), value, SvPEEK(value)));
            if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv) &&
                SvTYPE(sv) != SVt_PVGV)
            {
@@ -691,20 +691,20 @@ Perl_leave_scope(pTHX_ I32 base)
                     SvTYPE(value) != SVt_PVGV)
            {
                SvFLAGS(value) |= (SvFLAGS(value) &
-                                  (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
+                                 (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
                SvMAGICAL_off(value);
                /* XXX this is a leak when we get here because the
                 * mg_get() in save_scalar_at() croaked */
                SvMAGIC(value) = 0;
            }
-            SvREFCNT_dec(sv);
+           SvREFCNT_dec(sv);
            *(SV**)ptr = value;
            PL_localizing = 2;
            SvSETMAGIC(value);
            PL_localizing = 0;
            SvREFCNT_dec(value);
-            break;
-        case SAVEt_AV:                         /* array reference */
+           break;
+       case SAVEt_AV:                          /* array reference */
            av = (AV*)SSPOPPTR;
            gv = (GV*)SSPOPPTR;
            if (GvAV(gv)) {
@@ -715,14 +715,14 @@ Perl_leave_scope(pTHX_ I32 base)
                SvMAGIC(goner) = 0;
                SvREFCNT_dec(goner);
            }
-            GvAV(gv) = av;
+           GvAV(gv) = av;
            if (SvMAGICAL(av)) {
                PL_localizing = 2;
                SvSETMAGIC((SV*)av);
                PL_localizing = 0;
            }
-            break;
-        case SAVEt_HV:                         /* hash reference */
+           break;
+       case SAVEt_HV:                          /* hash reference */
            hv = (HV*)SSPOPPTR;
            gv = (GV*)SSPOPPTR;
            if (GvHV(gv)) {
@@ -733,13 +733,13 @@ Perl_leave_scope(pTHX_ I32 base)
                SvMAGIC(goner) = 0;
                SvREFCNT_dec(goner);
            }
-            GvHV(gv) = hv;
+           GvHV(gv) = hv;
            if (SvMAGICAL(hv)) {
                PL_localizing = 2;
                SvSETMAGIC((SV*)hv);
                PL_localizing = 0;
            }
-            break;
+           break;
        case SAVEt_INT:                         /* int reference */
            ptr = SSPOPPTR;
            *(int*)ptr = (int)SSPOPINT;
@@ -788,18 +788,18 @@ Perl_leave_scope(pTHX_ I32 base)
        case SAVEt_GP:                          /* scalar reference */
            ptr = SSPOPPTR;
            gv = (GV*)SSPOPPTR;
-            if (SvPVX(gv) && SvLEN(gv) > 0) {
-                Safefree(SvPVX(gv));
-            }
-            SvPVX(gv) = (char *)SSPOPPTR;
-            SvCUR(gv) = (STRLEN)SSPOPIV;
-            SvLEN(gv) = (STRLEN)SSPOPIV;
-            gp_free(gv);
-            GvGP(gv) = (GP*)ptr;
+           if (SvPVX(gv) && SvLEN(gv) > 0) {
+               Safefree(SvPVX(gv));
+           }
+           SvPVX(gv) = (char *)SSPOPPTR;
+           SvCUR(gv) = (STRLEN)SSPOPIV;
+           SvLEN(gv) = (STRLEN)SSPOPIV;
+           gp_free(gv);
+           GvGP(gv) = (GP*)ptr;
            if (GvCVu(gv))
                PL_sub_generation++;  /* putting a method back into circulation */
            SvREFCNT_dec(gv);
-            break;
+           break;
        case SAVEt_FREESV:
            ptr = SSPOPPTR;
            SvREFCNT_dec((SV*)ptr);
@@ -823,6 +823,15 @@ Perl_leave_scope(pTHX_ I32 base)
            sv = *(SV**)ptr;
            /* Can clear pad variable in place? */
            if (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) {
+               /*
+                * if a my variable that was made readonly is going out of
+                * scope, we want to remove the readonlyness so that it can
+                * go out of scope quietly
+                * Disabled as I don't see need yet NI-S 2001/12/18
+                */
+               if (0 && SvPADMY(sv) && ! SvFAKE(sv))
+                   SvREADONLY_off(sv);
+
                if (SvTHINKFIRST(sv))
                    sv_force_normal_flags(sv, SV_IMMEDIATE_UNREF);
                if (SvMAGICAL(sv))
@@ -867,7 +876,7 @@ Perl_leave_scope(pTHX_ I32 base)
            ptr = SSPOPPTR;
            (void)hv_delete(hv, (char*)ptr, (U32)SSPOPINT, G_DISCARD);
            SvREFCNT_dec(hv);
-           Safefree(ptr); 
+           Safefree(ptr);
            break;
        case SAVEt_DESTRUCTOR:
            ptr = SSPOPPTR;

diff --git a/sv.c b/sv.c
index b80c7e0..e9ac9e1 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -1422,8 +1422,8 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
        SvPVX(sv)       = 0;
        HvFILL(sv)      = 0;
        HvMAX(sv)       = 0;
-       HvKEYS(sv)      = 0;
-       SvNVX(sv)       = 0.0;
+       HvTOTALKEYS(sv) = 0;
+       HvPLACEHOLDERS(sv) = 0;
        SvMAGIC(sv)     = magic;
        SvSTASH(sv)     = stash;
        HvRITER(sv)     = 0;

diff --git a/t/lib/access.t b/t/lib/access.t
index b82b3e9..815808c 100644 (file)
--- a/t/lib/access.t
+++ b/t/lib/access.t
@@ -6,7 +6,7 @@ BEGIN {
 }
 
 $| = 1;
-print "1..15\n";
+print "1..19\n";
 
 my $t = 1;
 
@@ -30,6 +30,8 @@ ok(!access::readonly(%hash));
 
 ok(!access::readonly(%hash,1));
 
+ok(!access::readonly($hash{two},1));
+
 eval { $hash{'three'} = 3 };
 #warn "$@";
 ok($@ =~ /^Attempt to access to key 'three' in fixed hash/);
@@ -43,11 +45,20 @@ eval { $hash{"\x{2323}"} = 3 };
 ok($@ =~ /^Attempt to access to key '(.*)' in fixed hash/);
 #ok(ord($1) == 0x2323);
 
+eval { delete $hash{'two'}};
+#warn "$@";
+ok($@);
+
 eval { delete $hash{'one'}};
+ok(not $@);
+
+ok($hash{two} == 2);
+
+eval { delete $hash{'four'}};
 #warn "$@";
-ok($@ =~ /^Attempt to access to key 'one' in fixed hash/);
+ok($@ =~ /^Attempt to access to key 'four' in fixed hash/);
 
-ok(exists $hash{'one'});
+ok(not exists $hash{'one'});
 
 ok(!exists $hash{'three'});