add workaround for dlopen() bug on OpenBSD (relative paths that

[p5sagit/p5-mst-13.2.git] / hv.c

diff --git a/hv.c b/hv.c
index 9a7b31f..9b01db7 100644 (file)
--- a/hv.c
+++ b/hv.c
@@ -15,17 +15,8 @@
 #define PERL_IN_HV_C
 #include "perl.h"
 
-#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(pTHX)
+S_new_he(pTHX)
 {
     HE* he;
     LOCK_SV_MUTEX;
@@ -38,7 +29,7 @@ new_he(pTHX)
 }
 
 STATIC void
-del_he(pTHX_ HE *p)
+S_del_he(pTHX_ HE *p)
 {
     LOCK_SV_MUTEX;
     HeNEXT(p) = (HE*)PL_he_root;
@@ -47,7 +38,7 @@ del_he(pTHX_ HE *p)
 }
 
 STATIC void
-more_he(pTHX)
+S_more_he(pTHX)
 {
     register HE* he;
     register HE* heend;
@@ -62,7 +53,7 @@ more_he(pTHX)
 }
 
 STATIC HEK *
-save_hek(pTHX_ const char *str, I32 len, U32 hash)
+S_save_hek(pTHX_ const char *str, I32 len, U32 hash)
 {
     char *k;
     register HEK *hek;
@@ -82,6 +73,35 @@ Perl_unshare_hek(pTHX_ HEK *hek)
     unsharepvn(HEK_KEY(hek),HEK_LEN(hek),HEK_HASH(hek));
 }
 
+#if defined(USE_ITHREADS)
+HE *
+Perl_he_dup(pTHX_ HE *e, bool shared)
+{
+    HE *ret;
+
+    if (!e)
+       return Nullhe;
+    /* look for it in the table first */
+    ret = (HE*)ptr_table_fetch(PL_ptr_table, e);
+    if (ret)
+       return ret;
+
+    /* create anew and remember what it is */
+    ret = new_he();
+    ptr_table_store(PL_ptr_table, e, ret);
+
+    HeNEXT(ret) = he_dup(HeNEXT(e),shared);
+    if (HeKLEN(e) == HEf_SVKEY)
+       HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e)));
+    else if (shared)
+       HeKEY_hek(ret) = share_hek(HeKEY(e), HeKLEN(e), HeHASH(e));
+    else
+       HeKEY_hek(ret) = save_hek(HeKEY(e), HeKLEN(e), HeHASH(e));
+    HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e)));
+    return ret;
+}
+#endif /* USE_ITHREADS */
+
 /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
  * contains an SV* */
 
@@ -126,7 +146,8 @@ Perl_hv_fetch(pTHX_ HV *hv, const char *key, U32 klen, I32 lval)
                 || (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME))
 #endif
                                                                  )
-           Newz(503,xhv->xhv_array, ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
+           Newz(503, xhv->xhv_array,
+                PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
        else
            return 0;
     }
@@ -214,7 +235,8 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
                 || (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME))
 #endif
                                                                  )
-           Newz(503,xhv->xhv_array, ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
+           Newz(503, xhv->xhv_array,
+                PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
        else
            return 0;
     }
@@ -253,7 +275,7 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
 }
 
 STATIC void
-hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store)
+S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store)
 {
     MAGIC *mg = SvMAGIC(hv);
     *needs_copy = FALSE;
@@ -304,7 +326,8 @@ Perl_hv_store(pTHX_ HV *hv, const char *key, U32 klen, SV *val, register U32 has
        PERL_HASH(hash, key, klen);
 
     if (!xhv->xhv_array)
-       Newz(505, xhv->xhv_array, ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
+       Newz(505, xhv->xhv_array,
+            PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
 
     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
     i = 1;
@@ -385,7 +408,8 @@ Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash)
        PERL_HASH(hash, key, klen);
 
     if (!xhv->xhv_array)
-       Newz(505, xhv->xhv_array, ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
+       Newz(505, xhv->xhv_array,
+            PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
 
     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
     i = 1;
@@ -478,8 +502,10 @@ Perl_hv_delete(pTHX_ HV *hv, const char *key, U32 klen, I32 flags)
            xhv->xhv_fill--;
        if (flags & G_DISCARD)
            sv = Nullsv;
-       else
-           sv = sv_mortalcopy(HeVAL(entry));
+       else {
+           sv = sv_2mortal(HeVAL(entry));
+           HeVAL(entry) = &PL_sv_undef;
+       }
        if (entry == xhv->xhv_eiter)
            HvLAZYDEL_on(hv);
        else
@@ -552,8 +578,10 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
            xhv->xhv_fill--;
        if (flags & G_DISCARD)
            sv = Nullsv;
-       else
-           sv = sv_mortalcopy(HeVAL(entry));
+       else {
+           sv = sv_2mortal(HeVAL(entry));
+           HeVAL(entry) = &PL_sv_undef;
+       }
        if (entry == xhv->xhv_eiter)
            HvLAZYDEL_on(hv);
        else
@@ -700,7 +728,7 @@ Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
 }
 
 STATIC void
-hsplit(pTHX_ HV *hv)
+S_hsplit(pTHX_ HV *hv)
 {
     register XPVHV* xhv = (XPVHV*)SvANY(hv);
     I32 oldsize = (I32) xhv->xhv_max + 1; /* sic(k) */
@@ -714,21 +742,21 @@ hsplit(pTHX_ HV *hv)
 
     PL_nomemok = TRUE;
 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
-    Renew(a, ARRAY_ALLOC_BYTES(newsize), char);
+    Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
     if (!a) {
       PL_nomemok = FALSE;
       return;
     }
 #else
 #define MALLOC_OVERHEAD 16
-    New(2, a, ARRAY_ALLOC_BYTES(newsize), char);
+    New(2, a, PERL_HV_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));
+       offer_nice_chunk(xhv->xhv_array, PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
     }
     else
        Safefree(xhv->xhv_array);
@@ -789,20 +817,20 @@ Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
     if (a) {
        PL_nomemok = TRUE;
 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
-       Renew(a, ARRAY_ALLOC_BYTES(newsize), char);
+       Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
         if (!a) {
          PL_nomemok = FALSE;
          return;
        }
 #else
-       New(2, a, ARRAY_ALLOC_BYTES(newsize), char);
+       New(2, a, PERL_HV_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));
+           offer_nice_chunk(xhv->xhv_array, PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
        }
        else
            Safefree(xhv->xhv_array);
@@ -811,7 +839,7 @@ Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
        Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
     }
     else {
-       Newz(0, a, ARRAY_ALLOC_BYTES(newsize), char);
+       Newz(0, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
     }
     xhv->xhv_max = --newsize;
     xhv->xhv_array = a;
@@ -957,7 +985,7 @@ Perl_hv_clear(pTHX_ HV *hv)
 }
 
 STATIC void
-hfreeentries(pTHX_ HV *hv)
+S_hfreeentries(pTHX_ HV *hv)
 {
     register HE **array;
     register HE *entry;
@@ -1018,7 +1046,7 @@ Perl_hv_iterinit(pTHX_ HV *hv)
     HE *entry;
 
     if (!hv)
-       croak("Bad hash");
+       Perl_croak(aTHX_ "Bad hash");
     xhv = (XPVHV*)SvANY(hv);
     entry = xhv->xhv_eiter;
     if (entry && HvLAZYDEL(hv)) {      /* was deleted earlier? */
@@ -1039,7 +1067,7 @@ Perl_hv_iternext(pTHX_ HV *hv)
     MAGIC* mg;
 
     if (!hv)
-       croak("Bad hash");
+       Perl_croak(aTHX_ "Bad hash");
     xhv = (XPVHV*)SvANY(hv);
     oldentry = entry = xhv->xhv_eiter;
 
@@ -1079,7 +1107,8 @@ Perl_hv_iternext(pTHX_ HV *hv)
 #endif
 
     if (!xhv->xhv_array)
-       Newz(506,xhv->xhv_array, ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
+       Newz(506, xhv->xhv_array,
+            PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
     if (entry)
        entry = HeNEXT(entry);
     while (!entry) {
@@ -1204,8 +1233,11 @@ Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
     }
     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