Re: Argument "1.23_45" isn't numeric in subroutine entry

[perl5.git] / hv.c

diff --git a/hv.c b/hv.c
index d0859d8..f92e31e 100644 (file)
--- a/hv.c
+++ b/hv.c
@@ -1,6 +1,6 @@
 /*    hv.c
  *
- *    Copyright (c) 1991-2001, Larry Wall
+ *    Copyright (c) 1991-2002, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -11,6 +11,10 @@
  * "I sit beside the fire and think of all that I have seen."  --Bilbo
  */
 
+/* 
+=head1 Hash Manipulation Functions
+*/
+
 #include "EXTERN.h"
 #define PERL_IN_HV_C
 #include "perl.h"
@@ -81,9 +85,10 @@ S_save_hek(pTHX_ const char *str, I32 len, U32 hash)
       is_utf8 = TRUE;
     }
 
-    New(54, k, HEK_BASESIZE + len + 1, char);
+    New(54, k, HEK_BASESIZE + len + 2, char);
     hek = (HEK*)k;
     Copy(str, HEK_KEY(hek), len, char);
+    HEK_KEY(hek)[len] = 0;
     HEK_LEN(hek) = len;
     HEK_HASH(hek) = hash;
     HEK_UTF8(hek) = (char)is_utf8;
@@ -128,7 +133,7 @@ Perl_he_dup(pTHX_ HE *e, bool shared, CLONE_PARAMS* param)
 
 static void
 Perl_hv_notallowed(pTHX_ bool is_utf8, const char *key, I32 klen,
-                  const char *keysave)
+                  const char *keysave, const char *msg)
 {
     SV *sv = sv_newmortal();
     if (key == keysave) {
@@ -142,7 +147,7 @@ Perl_hv_notallowed(pTHX_ bool is_utf8, const char *key, I32 klen,
     if (is_utf8) {
        SvUTF8_on(sv);
     }
-    Perl_croak(aTHX_ "Attempt to access to key '%_' in fixed hash",sv);
+    Perl_croak(aTHX_ msg, sv);
 }
 
 /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
@@ -261,7 +266,9 @@ Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen, I32 lval)
     }
 #endif
     if (!entry && SvREADONLY(hv)) {
-       Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave);
+       Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave,
+                 "Attempt to access disallowed key '%"SVf"' in a fixed hash"
+                           );
     }
     if (lval) {                /* gonna assign to this, so it better be there */
        sv = NEWSV(61,0);
@@ -395,7 +402,9 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
     }
 #endif
     if (!entry && SvREADONLY(hv)) {
-       Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave);
+       Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave,
+                 "Attempt to access disallowed key '%"SVf"' in a fixed hash"
+                           );
     }
     if (key != keysave)
        Safefree(key);
@@ -479,11 +488,13 @@ Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, register U32 has
 #endif
        }
     }
+
     if (is_utf8) {
        STRLEN tmplen = klen;
        /* See the note in hv_fetch(). --jhi */
        key = (char*)bytes_from_utf8((U8*)key, &tmplen, &is_utf8);
        klen = tmplen;
+       HvUTF8KEYS_on((SV*)hv);
     }
 
     if (!hash)
@@ -518,7 +529,9 @@ Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, register U32 has
     }
 
     if (SvREADONLY(hv)) {
-       Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave);
+       Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave,
+                 "Attempt to access disallowed key '%"SVf"' to a fixed hash"
+                           );
     }
 
     entry = new_HE();
@@ -604,8 +617,10 @@ Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash)
     keysave = key = SvPV(keysv, klen);
     is_utf8 = (SvUTF8(keysv) != 0);
 
-    if (is_utf8)
+    if (is_utf8) {
        key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
+       HvUTF8KEYS_on((SV*)hv);
+    }
 
     if (!hash)
        PERL_HASH(hash, key, klen);
@@ -639,7 +654,9 @@ Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash)
     }
 
     if (SvREADONLY(hv)) {
-       Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave);
+       Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave,
+                 "Attempt to access disallowed key '%"SVf"' to a fixed hash"
+                           );
     }
 
     entry = new_HE();
@@ -760,12 +777,16 @@ Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags)
                else
                    hv_free_ent(hv, entry);
                xhv->xhv_keys--; /* HvKEYS(hv)-- */
+               if (xhv->xhv_keys == 0)
+                   HvUTF8KEYS_off(hv);
                xhv->xhv_placeholders--;
                return Nullsv;
            }
        }
        else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
-           Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave);
+           Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave,
+                   "Attempt to delete readonly key '%"SVf"' from a fixed hash"
+                               );
        }
 
        if (flags & G_DISCARD)
@@ -795,11 +816,15 @@ Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags)
            else
                hv_free_ent(hv, entry);
            xhv->xhv_keys--; /* HvKEYS(hv)-- */
+           if (xhv->xhv_keys == 0)
+               HvUTF8KEYS_off(hv);
        }
        return sv;
     }
     if (SvREADONLY(hv)) {
-       Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave);
+       Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave,
+               "Attempt to access disallowed key '%"SVf"' from a fixed hash"
+                           );
     }
 
     if (key != keysave)
@@ -893,22 +918,25 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
        {
            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;
-           }
+
+           /* 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)-- */
+          if (xhv->xhv_keys == 0)
+               HvUTF8KEYS_off(hv);
+           xhv->xhv_placeholders--;
+           return Nullsv;
        }
        else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
-           Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave);
+           Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave,
+                   "Attempt to delete readonly key '%"SVf"' from a fixed hash"
+                               );
        }
 
        if (flags & G_DISCARD)
@@ -938,11 +966,15 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
            else
                hv_free_ent(hv, entry);
            xhv->xhv_keys--; /* HvKEYS(hv)-- */
+           if (xhv->xhv_keys == 0)
+               HvUTF8KEYS_off(hv);
        }
        return sv;
     }
     if (SvREADONLY(hv)) {
-       Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave);
+        Perl_hv_notallowed(aTHX_ is_utf8, key, klen, keysave,
+            "Attempt to delete disallowed key '%"SVf"' from a fixed hash"
+           );
     }
 
     if (key != keysave)
@@ -1442,6 +1474,11 @@ Perl_hv_clear(pTHX_ HV *hv)
     register XPVHV* xhv;
     if (!hv)
        return;
+
+    if(SvREADONLY(hv)) {
+        Perl_croak(aTHX_ "Attempt to clear a fixed hash");
+    }
+
     xhv = (XPVHV*)SvANY(hv);
     hfreeentries(hv);
     xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
@@ -1453,6 +1490,8 @@ Perl_hv_clear(pTHX_ HV *hv)
 
     if (SvRMAGICAL(hv))
        mg_clear((SV*)hv);
+
+    HvUTF8KEYS_off(hv);
 }
 
 STATIC void
@@ -1817,7 +1856,7 @@ Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
     if (str != save)
        Safefree(str);
     if (!found && ckWARN_d(WARN_INTERNAL))
-       Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free non-existent shared string '%s'",str);
+       Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Attempt to free non-existent shared string '%s'",str);
 }
 
 /* get a (constant) string ptr from the global string table