This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
add include guard
[perl5.git] / hv.c
diff --git a/hv.c b/hv.c
index f63dff8..857bd70 100644 (file)
--- a/hv.c
+++ b/hv.c
@@ -1,6 +1,6 @@
 /*    hv.c
  *
- *    Copyright (c) 1991-1997, Larry Wall
+ *    Copyright (c) 1991-1999, 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.
  */
 
 #include "EXTERN.h"
+#define PERL_IN_HV_C
 #include "perl.h"
 
-static void hsplit _((HV *hv));
-static void hfreeentries _((HV *hv));
-
-static HE* more_he();
+#if defined(STRANGE_MALLOC) || defined(MYMALLOC)
+#  define ARRAY_ALLOC_BYTES(size) ( (size)*sizeof(HE*) )
+#else
+#  define MALLOC_OVERHEAD 16
+#  define ARRAY_ALLOC_BYTES(size) ( ((size) < 64)      \
+                               ? (size)*sizeof(HE*)    \
+                               : (size)*sizeof(HE*)*2 - MALLOC_OVERHEAD )
+#endif
 
-static HE*
-new_he()
+STATIC HE*
+S_new_he(pTHX)
 {
     HE* he;
-    if (he_root) {
-        he = he_root;
-        he_root = HeNEXT(he);
-        return he;
-    }
-    return more_he();
+    LOCK_SV_MUTEX;
+    if (!PL_he_root)
+        more_he();
+    he = PL_he_root;
+    PL_he_root = HeNEXT(he);
+    UNLOCK_SV_MUTEX;
+    return he;
 }
 
-static void
-del_he(p)
-HE* p;
+STATIC void
+S_del_he(pTHX_ HE *p)
 {
-    HeNEXT(p) = (HE*)he_root;
-    he_root = p;
+    LOCK_SV_MUTEX;
+    HeNEXT(p) = (HE*)PL_he_root;
+    PL_he_root = p;
+    UNLOCK_SV_MUTEX;
 }
 
-static HE*
-more_he()
+STATIC void
+S_more_he(pTHX)
 {
     register HE* he;
     register HE* heend;
-    he_root = (HE*)safemalloc(1008);
-    he = he_root;
+    New(54, PL_he_root, 1008/sizeof(HE), HE);
+    he = PL_he_root;
     heend = &he[1008 / sizeof(HE) - 1];
     while (he < heend) {
         HeNEXT(he) = (HE*)(he + 1);
         he++;
     }
     HeNEXT(he) = 0;
-    return new_he();
 }
 
-static HEK *
-save_hek(str, len, hash)
-char *str;
-I32 len;
-U32 hash;
+STATIC HEK *
+S_save_hek(pTHX_ const char *str, I32 len, U32 hash)
 {
     char *k;
     register HEK *hek;
@@ -74,8 +77,7 @@ U32 hash;
 }
 
 void
-unshare_hek(hek)
-HEK *hek;
+Perl_unshare_hek(pTHX_ HEK *hek)
 {
     unsharepvn(HEK_KEY(hek),HEK_LEN(hek),HEK_HASH(hek));
 }
@@ -84,11 +86,7 @@ HEK *hek;
  * contains an SV* */
 
 SV**
-hv_fetch(hv,key,klen,lval)
-HV *hv;
-char *key;
-U32 klen;
-I32 lval;
+Perl_hv_fetch(pTHX_ HV *hv, const char *key, U32 klen, I32 lval)
 {
     register XPVHV* xhv;
     register U32 hash;
@@ -100,11 +98,25 @@ I32 lval;
 
     if (SvRMAGICAL(hv)) {
        if (mg_find((SV*)hv,'P')) {
+           dTHR;
            sv = sv_newmortal();
            mg_copy((SV*)hv, sv, key, klen);
-           Sv = sv;
-           return &Sv;
+           PL_hv_fetch_sv = sv;
+           return &PL_hv_fetch_sv;
+       }
+#ifdef ENV_IS_CASELESS
+       else if (mg_find((SV*)hv,'E')) {
+           U32 i;
+           for (i = 0; i < klen; ++i)
+               if (isLOWER(key[i])) {
+                   char *nkey = strupr(SvPVX(sv_2mortal(newSVpvn(key,klen))));
+                   SV **ret = hv_fetch(hv, nkey, klen, 0);
+                   if (!ret && lval)
+                       ret = hv_store(hv, key, klen, NEWSV(61,0), 0);
+                   return ret;
+               }
        }
+#endif
     }
 
     xhv = (XPVHV*)SvANY(hv);
@@ -114,7 +126,7 @@ I32 lval;
                 || (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME))
 #endif
                                                                  )
-           Newz(503,xhv->xhv_array, sizeof(HE*) * (xhv->xhv_max + 1), char);
+           Newz(503,xhv->xhv_array, ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
        else
            return 0;
     }
@@ -133,13 +145,13 @@ I32 lval;
     }
 #ifdef DYNAMIC_ENV_FETCH  /* %ENV lookup?  If so, try to fetch the value now */
     if (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME)) {
-      char *gotenv;
-
-      if ((gotenv = ENV_getenv(key)) != Nullch) {
-        sv = newSVpv(gotenv,strlen(gotenv));
-        SvTAINTED_on(sv);
-        return hv_store(hv,key,klen,sv,hash);
-      }
+       unsigned long len;
+       char *env = PerlEnv_ENVgetenv_len(key,&len);
+       if (env) {
+           sv = newSVpvn(env,len);
+           SvTAINTED_on(sv);
+           return hv_store(hv,key,klen,sv,hash);
+       }
     }
 #endif
     if (lval) {                /* gonna assign to this, so it better be there */
@@ -152,11 +164,7 @@ I32 lval;
 /* returns a HE * structure with the all fields set */
 /* note that hent_val will be a mortal sv for MAGICAL hashes */
 HE *
-hv_fetch_ent(hv,keysv,lval,hash)
-HV *hv;
-SV *keysv;
-I32 lval;
-register U32 hash;
+Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
 {
     register XPVHV* xhv;
     register char *key;
@@ -167,20 +175,36 @@ register U32 hash;
     if (!hv)
        return 0;
 
-    if (SvRMAGICAL(hv) && mg_find((SV*)hv,'P')) {
-       static HE mh;
-
-       sv = sv_newmortal();
-       keysv = sv_2mortal(newSVsv(keysv));
-       mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
-       if (!HeKEY_hek(&mh)) {
-           char *k;
-           New(54, k, HEK_BASESIZE + sizeof(SV*), char);
-           HeKEY_hek(&mh) = (HEK*)k;
+    if (SvRMAGICAL(hv)) {
+       if (mg_find((SV*)hv,'P')) {
+           dTHR;
+           sv = sv_newmortal();
+           keysv = sv_2mortal(newSVsv(keysv));
+           mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
+           if (!HeKEY_hek(&PL_hv_fetch_ent_mh)) {
+               char *k;
+               New(54, k, HEK_BASESIZE + sizeof(SV*), char);
+               HeKEY_hek(&PL_hv_fetch_ent_mh) = (HEK*)k;
+           }
+           HeSVKEY_set(&PL_hv_fetch_ent_mh, keysv);
+           HeVAL(&PL_hv_fetch_ent_mh) = sv;
+           return &PL_hv_fetch_ent_mh;
+       }
+#ifdef ENV_IS_CASELESS
+       else if (mg_find((SV*)hv,'E')) {
+           U32 i;
+           key = SvPV(keysv, klen);
+           for (i = 0; i < klen; ++i)
+               if (isLOWER(key[i])) {
+                   SV *nkeysv = sv_2mortal(newSVpvn(key,klen));
+                   (void)strupr(SvPVX(nkeysv));
+                   entry = hv_fetch_ent(hv, nkeysv, 0, 0);
+                   if (!entry && lval)
+                       entry = hv_store_ent(hv, keysv, NEWSV(61,0), hash);
+                   return entry;
+               }
        }
-       HeSVKEY_set(&mh, keysv);
-       HeVAL(&mh) = sv;
-       return &mh;
+#endif
     }
 
     xhv = (XPVHV*)SvANY(hv);
@@ -190,7 +214,7 @@ register U32 hash;
                 || (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME))
 #endif
                                                                  )
-           Newz(503,xhv->xhv_array, sizeof(HE*) * (xhv->xhv_max + 1), char);
+           Newz(503,xhv->xhv_array, ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
        else
            return 0;
     }
@@ -212,13 +236,13 @@ register U32 hash;
     }
 #ifdef DYNAMIC_ENV_FETCH  /* %ENV lookup?  If so, try to fetch the value now */
     if (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME)) {
-      char *gotenv;
-
-      if ((gotenv = ENV_getenv(key)) != Nullch) {
-        sv = newSVpv(gotenv,strlen(gotenv));
-        SvTAINTED_on(sv);
-        return hv_store_ent(hv,keysv,sv,hash);
-      }
+       unsigned long len;
+       char *env = PerlEnv_ENVgetenv_len(key,&len);
+       if (env) {
+           sv = newSVpvn(env,len);
+           SvTAINTED_on(sv);
+           return hv_store_ent(hv,keysv,sv,hash);
+       }
     }
 #endif
     if (lval) {                /* gonna assign to this, so it better be there */
@@ -228,13 +252,27 @@ register U32 hash;
     return 0;
 }
 
+STATIC void
+S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store)
+{
+    MAGIC *mg = SvMAGIC(hv);
+    *needs_copy = FALSE;
+    *needs_store = TRUE;
+    while (mg) {
+       if (isUPPER(mg->mg_type)) {
+           *needs_copy = TRUE;
+           switch (mg->mg_type) {
+           case 'P':
+           case 'S':
+               *needs_store = FALSE;
+           }
+       }
+       mg = mg->mg_moremagic;
+    }
+}
+
 SV**
-hv_store(hv,key,klen,val,hash)
-HV *hv;
-char *key;
-U32 klen;
-SV *val;
-register U32 hash;
+Perl_hv_store(pTHX_ HV *hv, const char *key, U32 klen, SV *val, register U32 hash)
 {
     register XPVHV* xhv;
     register I32 i;
@@ -246,21 +284,27 @@ register U32 hash;
 
     xhv = (XPVHV*)SvANY(hv);
     if (SvMAGICAL(hv)) {
-       mg_copy((SV*)hv, val, key, klen);
-       if (!xhv->xhv_array
-           && (SvMAGIC(hv)->mg_moremagic
-               || (SvMAGIC(hv)->mg_type != 'E'
-#ifdef OVERLOAD
-                   && SvMAGIC(hv)->mg_type != 'A'
-#endif /* OVERLOAD */
-                   )))
-           return 0;
+       bool needs_copy;
+       bool needs_store;
+       hv_magic_check (hv, &needs_copy, &needs_store);
+       if (needs_copy) {
+           mg_copy((SV*)hv, val, key, klen);
+           if (!xhv->xhv_array && !needs_store)
+               return 0;
+#ifdef ENV_IS_CASELESS
+           else if (mg_find((SV*)hv,'E')) {
+               SV *sv = sv_2mortal(newSVpvn(key,klen));
+               key = strupr(SvPVX(sv));
+               hash = 0;
+           }
+#endif
+       }
     }
     if (!hash)
        PERL_HASH(hash, key, klen);
 
     if (!xhv->xhv_array)
-       Newz(505, xhv->xhv_array, sizeof(HE**) * (xhv->xhv_max + 1), char);
+       Newz(505, xhv->xhv_array, ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
 
     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
     i = 1;
@@ -297,11 +341,7 @@ register U32 hash;
 }
 
 HE *
-hv_store_ent(hv,keysv,val,hash)
-HV *hv;
-SV *keysv;
-SV *val;
-register U32 hash;
+Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash)
 {
     register XPVHV* xhv;
     register char *key;
@@ -315,29 +355,37 @@ register U32 hash;
 
     xhv = (XPVHV*)SvANY(hv);
     if (SvMAGICAL(hv)) {
-       bool save_taint = tainted;
-       if (tainting)
-           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
-           && (SvMAGIC(hv)->mg_moremagic
-               || (SvMAGIC(hv)->mg_type != 'E'
-#ifdef OVERLOAD
-                   && SvMAGIC(hv)->mg_type != 'A'
-#endif /* OVERLOAD */
-                   )))
-         return Nullhe;
+       dTHR;
+       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 && !needs_store)
+               return Nullhe;
+#ifdef ENV_IS_CASELESS
+           else if (mg_find((SV*)hv,'E')) {
+               key = SvPV(keysv, klen);
+               keysv = sv_2mortal(newSVpvn(key,klen));
+               (void)strupr(SvPVX(keysv));
+               hash = 0;
+           }
+#endif
+       }
     }
 
     key = SvPV(keysv, klen);
-    
+
     if (!hash)
        PERL_HASH(hash, key, klen);
 
     if (!xhv->xhv_array)
-       Newz(505, xhv->xhv_array, sizeof(HE**) * (xhv->xhv_max + 1), char);
+       Newz(505, xhv->xhv_array, ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
 
     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
     i = 1;
@@ -374,31 +422,40 @@ register U32 hash;
 }
 
 SV *
-hv_delete(hv,key,klen,flags)
-HV *hv;
-char *key;
-U32 klen;
-I32 flags;
+Perl_hv_delete(pTHX_ HV *hv, const char *key, U32 klen, I32 flags)
 {
     register XPVHV* xhv;
     register I32 i;
     register U32 hash;
     register HE *entry;
     register HE **oentry;
+    SV **svp;
     SV *sv;
 
     if (!hv)
        return Nullsv;
     if (SvRMAGICAL(hv)) {
-       sv = *hv_fetch(hv, key, klen, TRUE);
-       mg_clear(sv);
-       if (mg_find(sv, 's')) {
-           return Nullsv;              /* %SIG elements cannot be deleted */
-       }
-       if (mg_find(sv, 'p')) {
-           sv_unmagic(sv, 'p');        /* No longer an element */
-           return sv;
-       }
+       bool needs_copy;
+       bool needs_store;
+       hv_magic_check (hv, &needs_copy, &needs_store);
+
+       if (needs_copy && (svp = hv_fetch(hv, key, klen, TRUE))) {
+           sv = *svp;
+           mg_clear(sv);
+           if (!needs_store) {
+               if (mg_find(sv, 'p')) {
+                   sv_unmagic(sv, 'p');        /* No longer an element */
+                   return sv;
+               }
+               return Nullsv;          /* element cannot be deleted */
+           }
+#ifdef ENV_IS_CASELESS
+           else if (mg_find((SV*)hv,'E')) {
+               sv = sv_2mortal(newSVpvn(key,klen));
+               key = strupr(SvPVX(sv));
+           }
+#endif
+        }
     }
     xhv = (XPVHV*)SvANY(hv);
     if (!xhv->xhv_array)
@@ -434,11 +491,7 @@ I32 flags;
 }
 
 SV *
-hv_delete_ent(hv,keysv,flags,hash)
-HV *hv;
-SV *keysv;
-I32 flags;
-U32 hash;
+Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
 {
     register XPVHV* xhv;
     register I32 i;
@@ -451,12 +504,28 @@ U32 hash;
     if (!hv)
        return Nullsv;
     if (SvRMAGICAL(hv)) {
-       entry = hv_fetch_ent(hv, keysv, TRUE, hash);
-       sv = HeVAL(entry);
-       mg_clear(sv);
-       if (mg_find(sv, 'p')) {
-           sv_unmagic(sv, 'p');        /* No longer an element */
-           return sv;
+       bool needs_copy;
+       bool needs_store;
+       hv_magic_check (hv, &needs_copy, &needs_store);
+
+       if (needs_copy && (entry = hv_fetch_ent(hv, keysv, TRUE, hash))) {
+           sv = HeVAL(entry);
+           mg_clear(sv);
+           if (!needs_store) {
+               if (mg_find(sv, 'p')) {
+                   sv_unmagic(sv, 'p');        /* No longer an element */
+                   return sv;
+               }               
+               return Nullsv;          /* element cannot be deleted */
+           }
+#ifdef ENV_IS_CASELESS
+           else if (mg_find((SV*)hv,'E')) {
+               key = SvPV(keysv, klen);
+               keysv = sv_2mortal(newSVpvn(key,klen));
+               (void)strupr(SvPVX(keysv));
+               hash = 0; 
+           }
+#endif
        }
     }
     xhv = (XPVHV*)SvANY(hv);
@@ -496,10 +565,7 @@ U32 hash;
 }
 
 bool
-hv_exists(hv,key,klen)
-HV *hv;
-char *key;
-U32 klen;
+Perl_hv_exists(pTHX_ HV *hv, const char *key, U32 klen)
 {
     register XPVHV* xhv;
     register U32 hash;
@@ -511,19 +577,32 @@ U32 klen;
 
     if (SvRMAGICAL(hv)) {
        if (mg_find((SV*)hv,'P')) {
+           dTHR;
            sv = sv_newmortal();
            mg_copy((SV*)hv, sv, key, klen); 
            magic_existspack(sv, mg_find(sv, 'p'));
            return SvTRUE(sv);
        }
+#ifdef ENV_IS_CASELESS
+       else if (mg_find((SV*)hv,'E')) {
+           sv = sv_2mortal(newSVpvn(key,klen));
+           key = strupr(SvPVX(sv));
+       }
+#endif
     }
 
     xhv = (XPVHV*)SvANY(hv);
+#ifndef DYNAMIC_ENV_FETCH
     if (!xhv->xhv_array)
        return 0; 
+#endif
 
     PERL_HASH(hash, key, klen);
 
+#ifdef DYNAMIC_ENV_FETCH
+    if (!xhv->xhv_array) entry = Null(HE*);
+    else
+#endif
     entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
     for (; entry; entry = HeNEXT(entry)) {
        if (HeHASH(entry) != hash)              /* strings can't be equal */
@@ -534,15 +613,24 @@ U32 klen;
            continue;
        return TRUE;
     }
+#ifdef DYNAMIC_ENV_FETCH  /* is it out there? */
+    if (HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME)) {
+       unsigned long len;
+       char *env = PerlEnv_ENVgetenv_len(key,&len);
+       if (env) {
+           sv = newSVpvn(env,len);
+           SvTAINTED_on(sv);
+           (void)hv_store(hv,key,klen,sv,hash);
+           return TRUE;
+       }
+    }
+#endif
     return FALSE;
 }
 
 
 bool
-hv_exists_ent(hv,keysv,hash)
-HV *hv;
-SV *keysv;
-U32 hash;
+Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
 {
     register XPVHV* xhv;
     register char *key;
@@ -555,22 +643,37 @@ U32 hash;
 
     if (SvRMAGICAL(hv)) {
        if (mg_find((SV*)hv,'P')) {
+           dTHR;               /* just for SvTRUE */
            sv = sv_newmortal();
            keysv = sv_2mortal(newSVsv(keysv));
            mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY); 
            magic_existspack(sv, mg_find(sv, 'p'));
            return SvTRUE(sv);
        }
+#ifdef ENV_IS_CASELESS
+       else if (mg_find((SV*)hv,'E')) {
+           key = SvPV(keysv, klen);
+           keysv = sv_2mortal(newSVpvn(key,klen));
+           (void)strupr(SvPVX(keysv));
+           hash = 0; 
+       }
+#endif
     }
 
     xhv = (XPVHV*)SvANY(hv);
+#ifndef DYNAMIC_ENV_FETCH
     if (!xhv->xhv_array)
        return 0; 
+#endif
 
     key = SvPV(keysv, klen);
     if (!hash)
        PERL_HASH(hash, key, klen);
 
+#ifdef DYNAMIC_ENV_FETCH
+    if (!xhv->xhv_array) entry = Null(HE*);
+    else
+#endif
     entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
     for (; entry; entry = HeNEXT(entry)) {
        if (HeHASH(entry) != hash)              /* strings can't be equal */
@@ -581,85 +684,93 @@ U32 hash;
            continue;
        return TRUE;
     }
+#ifdef DYNAMIC_ENV_FETCH  /* is it out there? */
+    if (HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME)) {
+       unsigned long len;
+       char *env = PerlEnv_ENVgetenv_len(key,&len);
+       if (env) {
+           sv = newSVpvn(env,len);
+           SvTAINTED_on(sv);
+           (void)hv_store_ent(hv,keysv,sv,hash);
+           return TRUE;
+       }
+    }
+#endif
     return FALSE;
 }
 
-static void
-hsplit(hv)
-HV *hv;
+STATIC void
+S_hsplit(pTHX_ HV *hv)
 {
     register XPVHV* xhv = (XPVHV*)SvANY(hv);
     I32 oldsize = (I32) xhv->xhv_max + 1; /* sic(k) */
     register I32 newsize = oldsize * 2;
     register I32 i;
-    register HE **a;
-    register HE **b;
+    register char *a = xhv->xhv_array;
+    register HE **aep;
+    register HE **bep;
     register HE *entry;
     register HE **oentry;
-#ifndef STRANGE_MALLOC
-    I32 tmp;
-#endif
 
-    a = (HE**)xhv->xhv_array;
-    nomemok = TRUE;
-#ifdef STRANGE_MALLOC
-    Renew(a, newsize, HE*);
+    PL_nomemok = TRUE;
+#if defined(STRANGE_MALLOC) || defined(MYMALLOC)
+    Renew(a, ARRAY_ALLOC_BYTES(newsize), char);
+    if (!a) {
+      PL_nomemok = FALSE;
+      return;
+    }
 #else
-    i = newsize * sizeof(HE*);
 #define MALLOC_OVERHEAD 16
-    tmp = MALLOC_OVERHEAD;
-    while (tmp - MALLOC_OVERHEAD < i)
-       tmp += tmp;
-    tmp -= MALLOC_OVERHEAD;
-    tmp /= sizeof(HE*);
-    assert(tmp >= newsize);
-    New(2,a, tmp, HE*);
-    Copy(xhv->xhv_array, a, oldsize, HE*);
-    if (oldsize >= 64 && !nice_chunk) {
-       nice_chunk = (char*)xhv->xhv_array;
-       nice_chunk_size = oldsize * sizeof(HE*) * 2 - MALLOC_OVERHEAD;
+    New(2, a, ARRAY_ALLOC_BYTES(newsize), char);
+    if (!a) {
+      PL_nomemok = FALSE;
+      return;
+    }
+    Copy(xhv->xhv_array, a, oldsize * sizeof(HE*), char);
+    if (oldsize >= 64) {
+       offer_nice_chunk(xhv->xhv_array, ARRAY_ALLOC_BYTES(oldsize));
     }
     else
        Safefree(xhv->xhv_array);
 #endif
 
-    nomemok = FALSE;
-    Zero(&a[oldsize], oldsize, HE*);           /* zero 2nd half*/
+    PL_nomemok = FALSE;
+    Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char);    /* zero 2nd half*/
     xhv->xhv_max = --newsize;
-    xhv->xhv_array = (char*)a;
+    xhv->xhv_array = a;
+    aep = (HE**)a;
 
-    for (i=0; i<oldsize; i++,a++) {
-       if (!*a)                                /* non-existent */
+    for (i=0; i<oldsize; i++,aep++) {
+       if (!*aep)                              /* non-existent */
            continue;
-       b = a+oldsize;
-       for (oentry = a, entry = *a; entry; entry = *oentry) {
+       bep = aep+oldsize;
+       for (oentry = aep, entry = *aep; entry; entry = *oentry) {
            if ((HeHASH(entry) & newsize) != i) {
                *oentry = HeNEXT(entry);
-               HeNEXT(entry) = *b;
-               if (!*b)
+               HeNEXT(entry) = *bep;
+               if (!*bep)
                    xhv->xhv_fill++;
-               *b = entry;
+               *bep = entry;
                continue;
            }
            else
                oentry = &HeNEXT(entry);
        }
-       if (!*a)                                /* everything moved */
+       if (!*aep)                              /* everything moved */
            xhv->xhv_fill--;
     }
 }
 
 void
-hv_ksplit(hv, newmax)
-HV *hv;
-IV newmax;
+Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
 {
     register XPVHV* xhv = (XPVHV*)SvANY(hv);
     I32 oldsize = (I32) xhv->xhv_max + 1; /* sic(k) */
     register I32 newsize;
     register I32 i;
     register I32 j;
-    register HE **a;
+    register char *a;
+    register HE **aep;
     register HE *entry;
     register HE **oentry;
 
@@ -674,61 +785,62 @@ IV newmax;
     if (newsize < newmax)
        return;                                 /* overflow detection */
 
-    a = (HE**)xhv->xhv_array;
+    a = xhv->xhv_array;
     if (a) {
-       nomemok = TRUE;
-#ifdef STRANGE_MALLOC
-       Renew(a, newsize, HE*);
+       PL_nomemok = TRUE;
+#if defined(STRANGE_MALLOC) || defined(MYMALLOC)
+       Renew(a, ARRAY_ALLOC_BYTES(newsize), char);
+        if (!a) {
+         PL_nomemok = FALSE;
+         return;
+       }
 #else
-       i = newsize * sizeof(HE*);
-       j = MALLOC_OVERHEAD;
-       while (j - MALLOC_OVERHEAD < i)
-           j += j;
-       j -= MALLOC_OVERHEAD;
-       j /= sizeof(HE*);
-       assert(j >= newsize);
-       New(2, a, j, HE*);
-       Copy(xhv->xhv_array, a, oldsize, HE*);
-       if (oldsize >= 64 && !nice_chunk) {
-           nice_chunk = (char*)xhv->xhv_array;
-           nice_chunk_size = oldsize * sizeof(HE*) * 2 - MALLOC_OVERHEAD;
+       New(2, a, ARRAY_ALLOC_BYTES(newsize), char);
+        if (!a) {
+         PL_nomemok = FALSE;
+         return;
+       }
+       Copy(xhv->xhv_array, a, oldsize * sizeof(HE*), char);
+       if (oldsize >= 64) {
+           offer_nice_chunk(xhv->xhv_array, ARRAY_ALLOC_BYTES(oldsize));
        }
        else
            Safefree(xhv->xhv_array);
 #endif
-       nomemok = FALSE;
-       Zero(&a[oldsize], newsize-oldsize, HE*); /* zero 2nd half*/
+       PL_nomemok = FALSE;
+       Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
     }
     else {
-       Newz(0, a, newsize, HE*);
+       Newz(0, a, ARRAY_ALLOC_BYTES(newsize), char);
     }
     xhv->xhv_max = --newsize;
-    xhv->xhv_array = (char*)a;
+    xhv->xhv_array = a;
     if (!xhv->xhv_fill)                                /* skip rest if no entries */
        return;
 
-    for (i=0; i<oldsize; i++,a++) {
-       if (!*a)                                /* non-existent */
+    aep = (HE**)a;
+    for (i=0; i<oldsize; i++,aep++) {
+       if (!*aep)                              /* non-existent */
            continue;
-       for (oentry = a, entry = *a; entry; entry = *oentry) {
+       for (oentry = aep, entry = *aep; entry; entry = *oentry) {
            if ((j = (HeHASH(entry) & newsize)) != i) {
                j -= i;
                *oentry = HeNEXT(entry);
-               if (!(HeNEXT(entry) = a[j]))
+               if (!(HeNEXT(entry) = aep[j]))
                    xhv->xhv_fill++;
-               a[j] = entry;
+               aep[j] = entry;
                continue;
            }
            else
                oentry = &HeNEXT(entry);
        }
-       if (!*a)                                /* everything moved */
+       if (!*aep)                              /* everything moved */
            xhv->xhv_fill--;
     }
 }
 
 HV *
-newHV()
+Perl_newHV(pTHX)
 {
     register HV *hv;
     register XPVHV* xhv;
@@ -748,16 +860,55 @@ newHV()
     return hv;
 }
 
+HV *
+Perl_newHVhv(pTHX_ HV *ohv)
+{
+    register HV *hv;
+    STRLEN hv_max = ohv ? HvMAX(ohv) : 0;
+    STRLEN hv_fill = ohv ? HvFILL(ohv) : 0;
+
+    hv = newHV();
+    while (hv_max && hv_max + 1 >= hv_fill * 2)
+       hv_max = hv_max / 2;    /* Is always 2^n-1 */
+    HvMAX(hv) = hv_max;
+    if (!hv_fill)
+       return hv;
+
+#if 0
+    if (! SvTIED_mg((SV*)ohv, 'P')) {
+       /* Quick way ???*/
+    } 
+    else 
+#endif
+    {
+       HE *entry;
+       I32 hv_riter = HvRITER(ohv);    /* current root of iterator */
+       HE *hv_eiter = HvEITER(ohv);    /* current entry of iterator */
+       
+       /* Slow way */
+       hv_iterinit(ohv);
+       while (entry = hv_iternext(ohv)) {
+           hv_store(hv, HeKEY(entry), HeKLEN(entry), 
+                    SvREFCNT_inc(HeVAL(entry)), HeHASH(entry));
+       }
+       HvRITER(ohv) = hv_riter;
+       HvEITER(ohv) = hv_eiter;
+    }
+    
+    return hv;
+}
+
 void
-hv_free_ent(hv, entry)
-HV *hv;
-register HE *entry;
+Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
 {
+    SV *val;
+
     if (!entry)
        return;
-    if (isGV(HeVAL(entry)) && GvCVu(HeVAL(entry)) && HvNAME(hv))
-       sub_generation++;       /* may be deletion of method from stash */
-    SvREFCNT_dec(HeVAL(entry));
+    val = HeVAL(entry);
+    if (val && isGV(val) && GvCVu(val) && HvNAME(hv))
+       PL_sub_generation++;    /* may be deletion of method from stash */
+    SvREFCNT_dec(val);
     if (HeKLEN(entry) == HEf_SVKEY) {
        SvREFCNT_dec(HeKEY_sv(entry));
         Safefree(HeKEY_hek(entry));
@@ -770,14 +921,12 @@ register HE *entry;
 }
 
 void
-hv_delayfree_ent(hv, entry)
-HV *hv;
-register HE *entry;
+Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
 {
     if (!entry)
        return;
     if (isGV(HeVAL(entry)) && GvCVu(HeVAL(entry)) && HvNAME(hv))
-       sub_generation++;       /* may be deletion of method from stash */
+       PL_sub_generation++;    /* may be deletion of method from stash */
     sv_2mortal(HeVAL(entry));  /* free between statements */
     if (HeKLEN(entry) == HEf_SVKEY) {
        sv_2mortal(HeKEY_sv(entry));
@@ -791,8 +940,7 @@ register HE *entry;
 }
 
 void
-hv_clear(hv)
-HV *hv;
+Perl_hv_clear(pTHX_ HV *hv)
 {
     register XPVHV* xhv;
     if (!hv)
@@ -808,9 +956,8 @@ HV *hv;
        mg_clear((SV*)hv); 
 }
 
-static void
-hfreeentries(hv)
-HV *hv;
+STATIC void
+S_hfreeentries(pTHX_ HV *hv)
 {
     register HE **array;
     register HE *entry;
@@ -843,8 +990,7 @@ HV *hv;
 }
 
 void
-hv_undef(hv)
-HV *hv;
+Perl_hv_undef(pTHX_ HV *hv)
 {
     register XPVHV* xhv;
     if (!hv)
@@ -866,32 +1012,26 @@ HV *hv;
 }
 
 I32
-hv_iterinit(hv)
-HV *hv;
+Perl_hv_iterinit(pTHX_ HV *hv)
 {
     register XPVHV* xhv;
     HE *entry;
 
     if (!hv)
-       croak("Bad hash");
+       Perl_croak(aTHX_ "Bad hash");
     xhv = (XPVHV*)SvANY(hv);
     entry = xhv->xhv_eiter;
-#ifdef DYNAMIC_ENV_FETCH  /* set up %ENV for iteration */
-    if (HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME))
-       prime_env_iter();
-#endif
     if (entry && HvLAZYDEL(hv)) {      /* was deleted earlier? */
        HvLAZYDEL_off(hv);
        hv_free_ent(hv, entry);
     }
     xhv->xhv_riter = -1;
     xhv->xhv_eiter = Null(HE*);
-    return xhv->xhv_fill;
+    return xhv->xhv_keys;      /* used to be xhv->xhv_fill before 5.004_65 */
 }
 
 HE *
-hv_iternext(hv)
-HV *hv;
+Perl_hv_iternext(pTHX_ HV *hv)
 {
     register XPVHV* xhv;
     register HE *entry;
@@ -899,11 +1039,11 @@ HV *hv;
     MAGIC* mg;
 
     if (!hv)
-       croak("Bad hash");
+       Perl_croak(aTHX_ "Bad hash");
     xhv = (XPVHV*)SvANY(hv);
     oldentry = entry = xhv->xhv_eiter;
 
-    if (SvRMAGICAL(hv) && (mg = mg_find((SV*)hv,'P'))) {
+    if (mg = SvTIED_mg((SV*)hv, 'P')) {
        SV *key = sv_newmortal();
        if (entry) {
            sv_setsv(key, HeSVKEY_force(entry));
@@ -933,9 +1073,13 @@ HV *hv;
        xhv->xhv_eiter = Null(HE*);
        return Null(HE*);
     }
+#ifdef DYNAMIC_ENV_FETCH  /* set up %ENV for iteration */
+    if (!entry && HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME))
+       prime_env_iter();
+#endif
 
     if (!xhv->xhv_array)
-       Newz(506,xhv->xhv_array, sizeof(HE*) * (xhv->xhv_max + 1), char);
+       Newz(506,xhv->xhv_array, ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
     if (entry)
        entry = HeNEXT(entry);
     while (!entry) {
@@ -957,12 +1101,13 @@ HV *hv;
 }
 
 char *
-hv_iterkey(entry,retlen)
-register HE *entry;
-I32 *retlen;
+Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
 {
     if (HeKLEN(entry) == HEf_SVKEY) {
-       return SvPV(HeKEY_sv(entry), *(STRLEN*)retlen);
+       STRLEN len;
+       char *p = SvPV(HeKEY_sv(entry), len);
+       *retlen = len;
+       return p;
     }
     else {
        *retlen = HeKLEN(entry);
@@ -972,20 +1117,17 @@ I32 *retlen;
 
 /* unlike hv_iterval(), this always returns a mortal copy of the key */
 SV *
-hv_iterkeysv(entry)
-register HE *entry;
+Perl_hv_iterkeysv(pTHX_ register HE *entry)
 {
     if (HeKLEN(entry) == HEf_SVKEY)
        return sv_mortalcopy(HeKEY_sv(entry));
     else
-       return sv_2mortal(newSVpv((HeKLEN(entry) ? HeKEY(entry) : ""),
+       return sv_2mortal(newSVpvn((HeKLEN(entry) ? HeKEY(entry) : ""),
                                  HeKLEN(entry)));
 }
 
 SV *
-hv_iterval(hv,entry)
-HV *hv;
-register HE *entry;
+Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
 {
     if (SvRMAGICAL(hv)) {
        if (mg_find((SV*)hv,'P')) {
@@ -1000,10 +1142,7 @@ register HE *entry;
 }
 
 SV *
-hv_iternextsv(hv, key, retlen)
-    HV *hv;
-    char **key;
-    I32 *retlen;
+Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
 {
     HE *he;
     if ( (he = hv_iternext(hv)) == NULL)
@@ -1013,19 +1152,13 @@ hv_iternextsv(hv, key, retlen)
 }
 
 void
-hv_magic(hv, gv, how)
-HV* hv;
-GV* gv;
-int how;
+Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
 {
     sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
 }
 
 char*  
-sharepvn(sv, len, hash)
-char* sv;
-I32 len;
-U32 hash;
+Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash)
 {
     return HEK_KEY(share_hek(sv, len, hash));
 }
@@ -1034,10 +1167,7 @@ U32 hash;
  * len and hash must both be valid for str.
  */
 void
-unsharepvn(str, len, hash)
-char* str;
-I32 len;
-U32 hash;
+Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
 {
     register XPVHV* xhv;
     register HE *entry;
@@ -1046,12 +1176,13 @@ U32 hash;
     I32 found = 0;
     
     /* what follows is the moral equivalent of:
-    if ((Svp = hv_fetch(strtab, tmpsv, FALSE, hash))) {
+    if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
        if (--*Svp == Nullsv)
-           hv_delete(strtab, str, len, G_DISCARD, hash);
+           hv_delete(PL_strtab, str, len, G_DISCARD, hash);
     } */
-    xhv = (XPVHV*)SvANY(strtab);
+    xhv = (XPVHV*)SvANY(PL_strtab);
     /* assert(xhv_array != 0) */
+    LOCK_STRTAB_MUTEX;
     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
     for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
        if (HeHASH(entry) != hash)              /* strings can't be equal */
@@ -1071,9 +1202,13 @@ U32 hash;
        }
        break;
     }
+    UNLOCK_STRTAB_MUTEX;
     
-    if (!found)
-       warn("Attempt to free non-existent shared string");    
+    {
+        dTHR;
+        if (!found && ckWARN_d(WARN_INTERNAL))
+           Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free non-existent shared string");    
+    }
 }
 
 /* get a (constant) string ptr from the global string table
@@ -1081,10 +1216,7 @@ U32 hash;
  * len and hash must both be valid for str.
  */
 HEK *
-share_hek(str, len, hash)
-char *str;
-I32 len;
-register U32 hash;
+Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
 {
     register XPVHV* xhv;
     register HE *entry;
@@ -1094,11 +1226,12 @@ register U32 hash;
 
     /* what follows is the moral equivalent of:
        
-    if (!(Svp = hv_fetch(strtab, str, len, FALSE)))
-       hv_store(strtab, str, len, Nullsv, hash);
+    if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
+       hv_store(PL_strtab, str, len, Nullsv, hash);
     */
-    xhv = (XPVHV*)SvANY(strtab);
+    xhv = (XPVHV*)SvANY(PL_strtab);
     /* assert(xhv_array != 0) */
+    LOCK_STRTAB_MUTEX;
     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
     for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
        if (HeHASH(entry) != hash)              /* strings can't be equal */
@@ -1120,12 +1253,14 @@ register U32 hash;
        if (i) {                                /* initial entry? */
            ++xhv->xhv_fill;
            if (xhv->xhv_keys > xhv->xhv_max)
-               hsplit(strtab);
+               hsplit(PL_strtab);
        }
     }
 
     ++HeVAL(entry);                            /* use value slot as REFCNT */
+    UNLOCK_STRTAB_MUTEX;
     return HeKEY_hek(entry);
 }
 
 
+