X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=hv.c;h=d1835b2bbf9a28857d4e0cfe9ecceace605315dc;hb=5d0b10e0e277da4dc4a7c7f47ea4de1c0bbe695a;hp=93853a944f12304ea06f92f82461b2ed6b9a3920;hpb=6cef672beecb6487b28e1c85741db8c90f90f456;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/hv.c b/hv.c
index 93853a9..d1835b2 100644
--- a/hv.c
+++ b/hv.c
@@ -71,7 +71,8 @@ S_new_he(pTHX)
     LOCK_SV_MUTEX;
     if (!*root)
 	S_more_he(aTHX);
-    he = *root;
+    he = (HE*) *root;
+    assert(he);
     *root = HeNEXT(he);
     UNLOCK_SV_MUTEX;
     return he;
@@ -103,7 +104,7 @@ S_save_hek_flags(const char *str, I32 len, U32 hash, int flags)
     HEK_KEY(hek)[len] = 0;
     HEK_LEN(hek) = len;
     HEK_HASH(hek) = hash;
-    HEK_FLAGS(hek) = (unsigned char)flags_masked;
+    HEK_FLAGS(hek) = (unsigned char)flags_masked | HVhek_UNSHARED;
 
     if (flags & HVhek_FREEKEY)
 	Safefree(str);
@@ -435,6 +436,8 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
 	return NULL;
 
     if (keysv) {
+	if (SvSMAGICAL(hv) && SvGMAGICAL(hv))
+	    keysv = hv_magic_uvar_xkey(hv, keysv, action);
 	if (flags & HVhek_FREEKEY)
 	    Safefree(key);
 	key = SvPV_const(keysv, klen);
@@ -964,6 +967,8 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
 	return NULL;
 
     if (keysv) {
+	if (SvSMAGICAL(hv) && SvGMAGICAL(hv))
+	    keysv = hv_magic_uvar_xkey(hv, keysv, -1);
 	if (k_flags & HVhek_FREEKEY)
 	    Safefree(key);
 	key = SvPV_const(keysv, klen);
@@ -1592,8 +1597,8 @@ Perl_hv_clear(pTHX_ HV *hv)
 		    if (HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
 			SV* const keysv = hv_iterkeysv(entry);
 			Perl_croak(aTHX_
-	"Attempt to delete readonly key '%"SVf"' from a restricted hash",
-				   keysv);
+				   "Attempt to delete readonly key '%"SVf"' from a restricted hash",
+				   (void*)keysv);
 		    }
 		    SvREFCNT_dec(HeVAL(entry));
 		    HeVAL(entry) = &PL_sv_placeholder;
@@ -1607,8 +1612,7 @@ Perl_hv_clear(pTHX_ HV *hv)
     hfreeentries(hv);
     HvPLACEHOLDERS_set(hv, 0);
     if (HvARRAY(hv))
-	(void)memzero(HvARRAY(hv),
-		      (xhv->xhv_max+1 /* HvMAX(hv)+1 */) * sizeof(HE*));
+	Zero(HvARRAY(hv), xhv->xhv_max+1 /* HvMAX(hv)+1 */, HE*);
 
     if (SvRMAGICAL(hv))
 	mg_clear((SV*)hv);
@@ -2117,7 +2121,7 @@ Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
 	iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
 	return NULL;
     }
-#ifdef DYNAMIC_ENV_FETCH  /* set up %ENV for iteration */
+#if defined(DYNAMIC_ENV_FETCH) && !defined(__riscos__)  /* set up %ENV for iteration */
     if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
 	prime_env_iter();
 #ifdef VMS
@@ -2511,6 +2515,24 @@ S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
     return HeKEY_hek(entry);
 }
 
+STATIC SV *
+S_hv_magic_uvar_xkey(pTHX_ HV* hv, SV* keysv, int action)
+{
+    MAGIC* mg;
+    if ((mg = mg_find((SV*)hv, PERL_MAGIC_uvar))) {
+	struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
+	if (uf->uf_set == NULL) {
+	    SV* obj = mg->mg_obj;
+	    mg->mg_obj = keysv;         /* pass key */
+	    uf->uf_index = action;      /* pass action */
+	    magic_getuvar((SV*)hv, mg);
+	    keysv = mg->mg_obj;         /* may have changed */
+	    mg->mg_obj = obj;
+	}
+    }
+    return keysv;
+}
+
 I32 *
 Perl_hv_placeholders_p(pTHX_ HV *hv)
 {
@@ -2552,6 +2574,52 @@ Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph)
     /* else we don't need to add magic to record 0 placeholders.  */
 }
 
+SV *
+S_refcounted_he_value(pTHX_ const struct refcounted_he *he)
+{
+    dVAR;
+    SV *value;
+    switch(he->refcounted_he_data[0] & HVrhek_typemask) {
+    case HVrhek_undef:
+	value = newSV(0);
+	break;
+    case HVrhek_delete:
+	value = &PL_sv_placeholder;
+	break;
+    case HVrhek_IV:
+	value = (he->refcounted_he_data[0] & HVrhek_UV)
+	    ? newSVuv(he->refcounted_he_val.refcounted_he_u_iv)
+	    : newSViv(he->refcounted_he_val.refcounted_he_u_uv);
+	break;
+    case HVrhek_PV:
+	/* Create a string SV that directly points to the bytes in our
+	   structure.  */
+	value = newSV(0);
+	sv_upgrade(value, SVt_PV);
+	SvPV_set(value, (char *) he->refcounted_he_data + 1);
+	SvCUR_set(value, he->refcounted_he_val.refcounted_he_u_len);
+	/* This stops anything trying to free it  */
+	SvLEN_set(value, 0);
+	SvPOK_on(value);
+	SvREADONLY_on(value);
+	if (he->refcounted_he_data[0] & HVrhek_UTF8)
+	    SvUTF8_on(value);
+	break;
+    default:
+	Perl_croak(aTHX_ "panic: refcounted_he_value bad flags %x",
+		   he->refcounted_he_data[0]);
+    }
+    return value;
+}
+
+#ifdef USE_ITHREADS
+/* A big expression to find the key offset */
+#define REF_HE_KEY(chain) \
+	((((chain->refcounted_he_data[0] & HVrhek_typemask) == HVrhek_PV) \
+	    ? chain->refcounted_he_val.refcounted_he_u_len + 1 : 0)	  \
+	 + 1 + chain->refcounted_he_data)
+#endif
+
 /*
 =for apidoc refcounted_he_chain_2hv
 
@@ -2563,6 +2631,7 @@ in C<struct refcounted_he *>.
 HV *
 Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain)
 {
+    dVAR;
     HV *hv = newHV();
     U32 placeholders = 0;
     /* We could chase the chain once to get an idea of the number of keys,
@@ -2588,7 +2657,26 @@ Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain)
 
 	for (; entry; entry = HeNEXT(entry)) {
 	    if (HeHASH(entry) == hash) {
-		goto next_please;
+		/* We might have a duplicate key here.  If so, entry is older
+		   than the key we've already put in the hash, so if they are
+		   the same, skip adding entry.  */
+#ifdef USE_ITHREADS
+		const STRLEN klen = HeKLEN(entry);
+		const char *const key = HeKEY(entry);
+		if (klen == chain->refcounted_he_keylen
+		    && (!!HeKUTF8(entry)
+			== !!(chain->refcounted_he_data[0] & HVhek_UTF8))
+		    && memEQ(key, REF_HE_KEY(chain), klen))
+		    goto next_please;
+#else
+		if (HeKEY_hek(entry) == chain->refcounted_he_hek)
+		    goto next_please;
+		if (HeKLEN(entry) == HEK_LEN(chain->refcounted_he_hek)
+		    && HeKUTF8(entry) == HEK_UTF8(chain->refcounted_he_hek)
+		    && memEQ(HeKEY(entry), HEK_KEY(chain->refcounted_he_hek),
+			     HeKLEN(entry)))
+		    goto next_please;
+#endif
 	    }
 	}
 	assert (!entry);
@@ -2596,11 +2684,7 @@ Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain)
 
 #ifdef USE_ITHREADS
 	HeKEY_hek(entry)
-	    = share_hek_flags(/* A big expression to find the key offset */
-			      (((chain->refcounted_he_data[0]
-				 & HVrhek_typemask) == HVrhek_PV)
-			       ? chain->refcounted_he_val.refcounted_he_u_len
-			       + 1 : 0) + 1 + chain->refcounted_he_data,
+	    = share_hek_flags(REF_HE_KEY(chain),
 			      chain->refcounted_he_keylen,
 			      chain->refcounted_he_hash,
 			      (chain->refcounted_he_data[0]
@@ -2608,38 +2692,9 @@ Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain)
 #else
 	HeKEY_hek(entry) = share_hek_hek(chain->refcounted_he_hek);
 #endif
-
-	switch(chain->refcounted_he_data[0] & HVrhek_typemask) {
-	case HVrhek_undef:
-	    value = newSV(0);
-	    break;
-	case HVrhek_delete:
-	    value = &PL_sv_placeholder;
+	value = refcounted_he_value(chain);
+	if (value == &PL_sv_placeholder)
 	    placeholders++;
-	    break;
-	case HVrhek_IV:
-	    value = (chain->refcounted_he_data[0] & HVrhek_UV)
-		? newSVuv(chain->refcounted_he_val.refcounted_he_u_iv)
-		: newSViv(chain->refcounted_he_val.refcounted_he_u_uv);
-	    break;
-	case HVrhek_PV:
-	    /* Create a string SV that directly points to the bytes in our
-	       structure.  */
-	    value = newSV(0);
-	    sv_upgrade(value, SVt_PV);
-	    SvPV_set(value, (char *) chain->refcounted_he_data + 1);
-	    SvCUR_set(value, chain->refcounted_he_val.refcounted_he_u_len);
-	    /* This stops anything trying to free it  */
-	    SvLEN_set(value, 0);
-	    SvPOK_on(value);
-	    SvREADONLY_on(value);
-	    if (chain->refcounted_he_data[0] & HVrhek_UTF8)
-		SvUTF8_on(value);
-	    break;
-	default:
-	    Perl_croak(aTHX_ "panic: refcounted_he_chain_2hv bad flags %x",
-		       chain->refcounted_he_data[0]);
-	}
 	HeVAL(entry) = value;
 
 	/* Link it into the chain.  */
@@ -2670,13 +2725,71 @@ Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain)
     return hv;
 }
 
+SV *
+Perl_refcounted_he_fetch(pTHX_ const struct refcounted_he *chain, SV *keysv,
+			 const char *key, STRLEN klen, int flags, U32 hash)
+{
+    dVAR;
+    /* Just to be awkward, if you're using this interface the UTF-8-or-not-ness
+       of your key has to exactly match that which is stored.  */
+    SV *value = &PL_sv_placeholder;
+    bool is_utf8;
+
+    if (keysv) {
+	if (flags & HVhek_FREEKEY)
+	    Safefree(key);
+	key = SvPV_const(keysv, klen);
+	flags = 0;
+	is_utf8 = (SvUTF8(keysv) != 0);
+    } else {
+	is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE);
+    }
+
+    if (!hash) {
+	if (keysv && (SvIsCOW_shared_hash(keysv))) {
+            hash = SvSHARED_HASH(keysv);
+        } else {
+            PERL_HASH(hash, key, klen);
+        }
+    }
+
+    for (; chain; chain = chain->refcounted_he_next) {
+#ifdef USE_ITHREADS
+	if (hash != chain->refcounted_he_hash)
+	    continue;
+	if (klen != chain->refcounted_he_keylen)
+	    continue;
+	if (memNE(REF_HE_KEY(chain),key,klen))
+	    continue;
+	if (!!is_utf8 != !!(chain->refcounted_he_data[0] & HVhek_UTF8))
+	    continue;
+#else
+	if (hash != HEK_HASH(chain->refcounted_he_hek))
+	    continue;
+	if (klen != (STRLEN)HEK_LEN(chain->refcounted_he_hek))
+	    continue;
+	if (memNE(HEK_KEY(chain->refcounted_he_hek),key,klen))
+	    continue;
+	if (!!is_utf8 != !!HEK_UTF8(chain->refcounted_he_hek))
+	    continue;
+#endif
+
+	value = sv_2mortal(refcounted_he_value(chain));
+	break;
+    }
+
+    if (flags & HVhek_FREEKEY)
+	Safefree(key);
+
+    return value;
+}
+
 /*
 =for apidoc refcounted_he_new
 
-Creates a new C<struct refcounted_he>. Assumes ownership of one reference
-to I<value>. As S<key> is copied into a shared hash key, all references remain
-the property of the caller. The C<struct refcounted_he> is returned with a
-reference count of 1.
+Creates a new C<struct refcounted_he>. As S<key> is copied, and value is
+stored in a compact form, all references remain the property of the caller.
+The C<struct refcounted_he> is returned with a reference count of 1.
 
 =cut
 */
@@ -2684,16 +2797,17 @@ reference count of 1.
 struct refcounted_he *
 Perl_refcounted_he_new(pTHX_ struct refcounted_he *const parent,
 		       SV *const key, SV *const value) {
+    dVAR;
     struct refcounted_he *he;
     STRLEN key_len;
     const char *key_p = SvPV_const(key, key_len);
     STRLEN value_len = 0;
-    const char *value_p;
+    const char *value_p = NULL;
     char value_type;
     char flags;
     STRLEN key_offset;
     U32 hash;
-    bool is_utf8 = SvUTF8(key);
+    bool is_utf8 = SvUTF8(key) ? TRUE : FALSE;
 
     if (SvPOK(value)) {
 	value_type = HVrhek_PV;
@@ -2717,12 +2831,14 @@ Perl_refcounted_he_new(pTHX_ struct refcounted_he *const parent,
     flags = value_type;
 
 #ifdef USE_ITHREADS
-    he = PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
-			      + key_len
-			      + key_offset);
+    he = (struct refcounted_he*)
+	PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
+			     + key_len
+			     + key_offset);
 #else
-    he = PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
-			      + key_offset);
+    he = (struct refcounted_he*)
+	PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
+			     + key_offset);
 #endif
 
 
@@ -2784,6 +2900,8 @@ and C<refcounted_he_free> iterates onto the parent node.
 
 void
 Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) {
+    PERL_UNUSED_CONTEXT;
+
     while (he) {
 	struct refcounted_he *copy;
 	U32 new_count;
@@ -2818,63 +2936,62 @@ Check that a hash is in an internally consistent state.
 void
 Perl_hv_assert(pTHX_ HV *hv)
 {
-  dVAR;
-  HE* entry;
-  int withflags = 0;
-  int placeholders = 0;
-  int real = 0;
-  int bad = 0;
-  const I32 riter = HvRITER_get(hv);
-  HE *eiter = HvEITER_get(hv);
-
-  (void)hv_iterinit(hv);
-
-  while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
-    /* sanity check the values */
-    if (HeVAL(entry) == &PL_sv_placeholder) {
-      placeholders++;
-    } else {
-      real++;
-    }
-    /* sanity check the keys */
-    if (HeSVKEY(entry)) {
-      /*EMPTY*/ /* Don't know what to check on SV keys.  */
-    } else if (HeKUTF8(entry)) {
-      withflags++;
-       if (HeKWASUTF8(entry)) {
-	 PerlIO_printf(Perl_debug_log,
-		       "hash key has both WASUFT8 and UTF8: '%.*s'\n",
-		       (int) HeKLEN(entry),  HeKEY(entry));
-	 bad = 1;
-       }
-    } else if (HeKWASUTF8(entry)) {
-      withflags++;
-    }
-  }
-  if (!SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
-    if (HvUSEDKEYS(hv) != real) {
-      PerlIO_printf(Perl_debug_log, "Count %d key(s), but hash reports %d\n",
-		    (int) real, (int) HvUSEDKEYS(hv));
-      bad = 1;
-    }
-    if (HvPLACEHOLDERS_get(hv) != placeholders) {
-      PerlIO_printf(Perl_debug_log,
-		    "Count %d placeholder(s), but hash reports %d\n",
-		    (int) placeholders, (int) HvPLACEHOLDERS_get(hv));
-      bad = 1;
-    }
-  }
-  if (withflags && ! HvHASKFLAGS(hv)) {
-    PerlIO_printf(Perl_debug_log,
-		  "Hash has HASKFLAGS off but I count %d key(s) with flags\n",
-		  withflags);
-    bad = 1;
-  }
-  if (bad) {
-    sv_dump((SV *)hv);
-  }
-  HvRITER_set(hv, riter);		/* Restore hash iterator state */
-  HvEITER_set(hv, eiter);
+    dVAR;
+    HE* entry;
+    int withflags = 0;
+    int placeholders = 0;
+    int real = 0;
+    int bad = 0;
+    const I32 riter = HvRITER_get(hv);
+    HE *eiter = HvEITER_get(hv);
+
+    (void)hv_iterinit(hv);
+
+    while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
+	/* sanity check the values */
+	if (HeVAL(entry) == &PL_sv_placeholder)
+	    placeholders++;
+	else
+	    real++;
+	/* sanity check the keys */
+	if (HeSVKEY(entry)) {
+	    NOOP;   /* Don't know what to check on SV keys.  */
+	} else if (HeKUTF8(entry)) {
+	    withflags++;
+	    if (HeKWASUTF8(entry)) {
+		PerlIO_printf(Perl_debug_log,
+			    "hash key has both WASUFT8 and UTF8: '%.*s'\n",
+			    (int) HeKLEN(entry),  HeKEY(entry));
+		bad = 1;
+	    }
+	} else if (HeKWASUTF8(entry))
+	    withflags++;
+    }
+    if (!SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
+	static const char bad_count[] = "Count %d %s(s), but hash reports %d\n";
+	const int nhashkeys = HvUSEDKEYS(hv);
+	const int nhashplaceholders = HvPLACEHOLDERS_get(hv);
+
+	if (nhashkeys != real) {
+	    PerlIO_printf(Perl_debug_log, bad_count, real, "keys", nhashkeys );
+	    bad = 1;
+	}
+	if (nhashplaceholders != placeholders) {
+	    PerlIO_printf(Perl_debug_log, bad_count, placeholders, "placeholder", nhashplaceholders );
+	    bad = 1;
+	}
+    }
+    if (withflags && ! HvHASKFLAGS(hv)) {
+	PerlIO_printf(Perl_debug_log,
+		    "Hash has HASKFLAGS off but I count %d key(s) with flags\n",
+		    withflags);
+	bad = 1;
+    }
+    if (bad) {
+	sv_dump((SV *)hv);
+    }
+    HvRITER_set(hv, riter);		/* Restore hash iterator state */
+    HvEITER_set(hv, eiter);
 }
 
 #endif