X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=hv.c;h=ee08ce4169d5e1537885c9522225c582633fb9e5;hb=67363c0d4f1afeee7e193e700845c9f68327d8c8;hp=b038d34e2b6170f74fcb6519babd87fc700a6b50;hpb=4c79ee7a1e7564ef83d0ac25d6677fdebb3ec7aa;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/hv.c b/hv.c
index b038d34..ee08ce4 100644
--- a/hv.c
+++ b/hv.c
@@ -1,6 +1,7 @@
 /*    hv.c
  *
- *    Copyright (c) 1991-2003, Larry Wall
+ *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ *    2000, 2001, 2002, 2003, by Larry Wall and others
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -89,6 +90,22 @@ S_save_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags)
     return hek;
 }
 
+/* free the pool of temporary HE/HEK pairs retunrned by hv_fetch_ent
+ * for tied hashes */
+
+void
+Perl_free_tied_hv_pool(pTHX)
+{
+    HE *ohe;
+    HE *he = PL_hv_fetch_ent_mh;
+    while (he) {
+	Safefree(HeKEY_hek(he));
+	ohe = he;
+	he = HeNEXT(he);
+	del_HE(ohe);
+    }
+}
+
 #if defined(USE_ITHREADS)
 HE *
 Perl_he_dup(pTHX_ HE *e, bool shared, CLONE_PARAMS* param)
@@ -107,8 +124,12 @@ Perl_he_dup(pTHX_ HE *e, bool shared, CLONE_PARAMS* param)
     ptr_table_store(PL_ptr_table, e, ret);
 
     HeNEXT(ret) = he_dup(HeNEXT(e),shared, param);
-    if (HeKLEN(e) == HEf_SVKEY)
+    if (HeKLEN(e) == HEf_SVKEY) {
+	char *k;
+	New(54, k, HEK_BASESIZE + sizeof(SV*), char);
+	HeKEY_hek(ret) = (HEK*)k;
 	HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e), param));
+    }
     else if (shared)
 	HeKEY_hek(ret) = share_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e),
                                          HeKFLAGS(e));
@@ -130,7 +151,7 @@ S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen,
     }
     else {
 	/* Need to free saved eventually assign to mortal SV */
-	SV *sv = sv_newmortal();
+	/* XXX is this line an error ???:  SV *sv = sv_newmortal(); */
 	sv_usepvn(sv, (char *) key, klen);
     }
     if (flags & HVhek_UTF8) {
@@ -208,11 +229,13 @@ S_hv_fetch_flags(pTHX_ HV *hv, const char *key, I32 klen, I32 lval, int flags)
         */
 	if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
 	    sv = sv_newmortal();
+	    sv_upgrade(sv, SVt_PVLV);
 	    mg_copy((SV*)hv, sv, key, klen);
             if (flags & HVhek_FREEKEY)
                 Safefree(key);
-	    PL_hv_fetch_sv = sv;
-	    return &PL_hv_fetch_sv;
+	    LvTYPE(sv) = 't';
+	    LvTARG(sv) = sv; /* fake (SV**) */
+	    return &(LvTARG(sv));
 	}
 #ifdef ENV_IS_CASELESS
 	else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
@@ -256,6 +279,8 @@ S_hv_fetch_flags(pTHX_ HV *hv, const char *key, I32 klen, I32 lval, int flags)
     /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
     entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
     for (; entry; entry = HeNEXT(entry)) {
+	if (!HeKEY_hek(entry))
+	    continue;
 	if (HeHASH(entry) != hash)		/* strings can't be equal */
 	    continue;
 	if (HeKLEN(entry) != (I32)klen)
@@ -356,17 +381,26 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
     if (SvRMAGICAL(hv)) {
 	if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
 	    sv = sv_newmortal();
-	    keysv = sv_2mortal(newSVsv(keysv));
+	    keysv = newSVsv(keysv);
 	    mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
-	    if (!HeKEY_hek(&PL_hv_fetch_ent_mh)) {
+	    /* grab a fake HE/HEK pair from the pool or make a new one */
+	    entry = PL_hv_fetch_ent_mh;
+	    if (entry)
+		PL_hv_fetch_ent_mh = HeNEXT(entry);
+	    else {
 		char *k;
+		entry = new_HE();
 		New(54, k, HEK_BASESIZE + sizeof(SV*), char);
-		HeKEY_hek(&PL_hv_fetch_ent_mh) = (HEK*)k;
+		HeKEY_hek(entry) = (HEK*)k;
 	    }
-	    HeSVKEY_set(&PL_hv_fetch_ent_mh, keysv);
-	    HeVAL(&PL_hv_fetch_ent_mh) = sv;
-	    return &PL_hv_fetch_ent_mh;
-	}
+	    HeNEXT(entry) = Nullhe;
+	    HeSVKEY_set(entry, keysv);
+	    HeVAL(entry) = sv;
+	    sv_upgrade(sv, SVt_PVLV);
+	    LvTYPE(sv) = 'T';
+	    LvTARG(sv) = (SV*)entry; /* so we can free entry when freeing sv */
+	    return entry;
+ 	}
 #ifdef ENV_IS_CASELESS
 	else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
 	    U32 i;
@@ -384,6 +418,7 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
 #endif
     }
 
+    keysave = key = SvPV(keysv, klen);
     xhv = (XPVHV*)SvANY(hv);
     if (!xhv->xhv_array /* !HvARRAY(hv) */) {
 	if (lval
@@ -398,7 +433,6 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
 	    return 0;
     }
 
-    keysave = key = SvPV(keysv, klen);
     is_utf8 = (SvUTF8(keysv)!=0);
 
     if (is_utf8) {
@@ -671,8 +705,8 @@ Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val,
     xhv->xhv_keys++; /* HvKEYS(hv)++ */
     if (i) {				/* initial entry? */
 	xhv->xhv_fill++; /* HvFILL(hv)++ */
-	if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */)
-	    hsplit(hv);
+    } else if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) {
+        hsplit(hv);
     }
 
     return &HeVAL(entry);
@@ -868,8 +902,8 @@ Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags)
     if (!hv)
 	return Nullsv;
     if (klen < 0) {
-      klen = -klen;
-      is_utf8 = TRUE;
+	klen = -klen;
+	is_utf8 = TRUE;
     }
     if (SvRMAGICAL(hv)) {
 	bool needs_copy;
@@ -878,7 +912,9 @@ Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags)
 
 	if (needs_copy && (svp = hv_fetch(hv, key, klen, TRUE))) {
 	    sv = *svp;
-	    mg_clear(sv);
+	    if (SvMAGICAL(sv)) {
+	        mg_clear(sv);
+	    }
 	    if (!needs_store) {
 		if (mg_find(sv, PERL_MAGIC_tiedelem)) {
 		    /* No longer an element */
@@ -1031,7 +1067,9 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
 
 	if (needs_copy && (entry = hv_fetch_ent(hv, keysv, TRUE, hash))) {
 	    sv = HeVAL(entry);
-	    mg_clear(sv);
+	    if (SvMAGICAL(sv)) {
+		mg_clear(sv);
+	    }
 	    if (!needs_store) {
 		if (mg_find(sv, PERL_MAGIC_tiedelem)) {
 		    /* No longer an element */
@@ -1665,14 +1703,33 @@ Perl_hv_clear(pTHX_ HV *hv)
     if (!hv)
 	return;
 
+    xhv = (XPVHV*)SvANY(hv);
+
     if(SvREADONLY(hv)) {
-        Perl_croak(aTHX_ "Attempt to clear a restricted hash");
+	/* restricted hash: convert all keys to placeholders */
+	I32 i;
+	HE* entry;
+	for (i=0; i< (I32) xhv->xhv_max; i++) {
+	    entry = ((HE**)xhv->xhv_array)[i];
+	    for (; entry; entry = HeNEXT(entry)) {
+		/* not already placeholder */
+		if (HeVAL(entry) != &PL_sv_undef) {
+		    if (HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
+			SV* keysv = hv_iterkeysv(entry);
+			Perl_croak(aTHX_
+	"Attempt to delete readonly key '%"SVf"' from a restricted hash",
+				   keysv);
+		    }
+		    SvREFCNT_dec(HeVAL(entry));
+		    HeVAL(entry) = &PL_sv_undef;
+		    xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
+		}
+	    }
+	}
+	return;
     }
 
-    xhv = (XPVHV*)SvANY(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) */,
@@ -1701,6 +1758,12 @@ S_hfreeentries(pTHX_ HV *hv)
     riter = 0;
     max = HvMAX(hv);
     array = HvARRAY(hv);
+    /* make everyone else think the array is empty, so that the destructors
+     * called for freed entries can't recusively mess with us */
+    HvARRAY(hv) = Null(HE**); 
+    HvFILL(hv) = 0;
+    ((XPVHV*) SvANY(hv))->xhv_keys = 0;
+
     entry = array[0];
     for (;;) {
 	if (entry) {
@@ -1714,6 +1777,7 @@ S_hfreeentries(pTHX_ HV *hv)
 	    entry = array[riter];
 	}
     }
+    HvARRAY(hv) = array;
     (void)hv_iterinit(hv);
 }
 
@@ -1735,13 +1799,13 @@ Perl_hv_undef(pTHX_ HV *hv)
     hfreeentries(hv);
     Safefree(xhv->xhv_array /* HvARRAY(hv) */);
     if (HvNAME(hv)) {
+        if(PL_stashcache)
+	    hv_delete(PL_stashcache, HvNAME(hv), strlen(HvNAME(hv)), G_DISCARD);
 	Safefree(HvNAME(hv));
 	HvNAME(hv) = 0;
     }
     xhv->xhv_max   = 7;	/* HvMAX(hv) = 7 (it's a normal hash) */
     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))