X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=hv.c;h=6fd6f2f3b03b572663b318556e62c30883be6f61;hb=e91177edb0beae74fd07fb1ec08a528ab1fb63c2;hp=f3ab6ccbb9f6f583479f4915a107a41f5cf672e9;hpb=aeea060ce4b653ecf5b0731f1cbfcf468f688acd;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/hv.c b/hv.c
index f3ab6cc..6fd6f2f 100644
--- a/hv.c
+++ b/hv.c
@@ -14,12 +14,14 @@
 #include "EXTERN.h"
 #include "perl.h"
 
+static void hv_magic_check _((HV *hv, bool *needs_copy, bool *needs_store));
+#ifndef PERL_OBJECT
 static void hsplit _((HV *hv));
 static void hfreeentries _((HV *hv));
+static HE* more_he _((void));
+#endif
 
-static HE* more_he(void);
-
-static HE*
+STATIC HE*
 new_he(void)
 {
     HE* he;
@@ -31,19 +33,19 @@ new_he(void)
     return more_he();
 }
 
-static void
+STATIC void
 del_he(HE *p)
 {
     HeNEXT(p) = (HE*)he_root;
     he_root = p;
 }
 
-static HE*
+STATIC HE*
 more_he(void)
 {
     register HE* he;
     register HE* heend;
-    he_root = (HE*)safemalloc(1008);
+    New(54, he_root, 1008/sizeof(HE), HE);
     he = he_root;
     heend = &he[1008 / sizeof(HE) - 1];
     while (he < heend) {
@@ -54,7 +56,7 @@ more_he(void)
     return new_he();
 }
 
-static HEK *
+STATIC HEK *
 save_hek(char *str, I32 len, U32 hash)
 {
     char *k;
@@ -94,9 +96,22 @@ hv_fetch(HV *hv, char *key, U32 klen, I32 lval)
 	    dTHR;
 	    sv = sv_newmortal();
 	    mg_copy((SV*)hv, sv, key, klen);
-	    Sv = sv;
-	    return &Sv;
+	    hv_fetch_sv = sv;
+	    return &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(newSVpv(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);
@@ -127,7 +142,7 @@ hv_fetch(HV *hv, char *key, U32 klen, I32 lval)
     if (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME)) {
       char *gotenv;
 
-      if ((gotenv = ENV_getenv(key)) != Nullch) {
+      if ((gotenv = PerlEnv_getenv(key)) != Nullch) {
         sv = newSVpv(gotenv,strlen(gotenv));
         SvTAINTED_on(sv);
         return hv_store(hv,key,klen,sv,hash);
@@ -155,20 +170,36 @@ hv_fetch_ent(HV *hv, SV *keysv, I32 lval, 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(&hv_fetch_ent_mh)) {
+		char *k;
+		New(54, k, HEK_BASESIZE + sizeof(SV*), char);
+		HeKEY_hek(&hv_fetch_ent_mh) = (HEK*)k;
+	    }
+	    HeSVKEY_set(&hv_fetch_ent_mh, keysv);
+	    HeVAL(&hv_fetch_ent_mh) = sv;
+	    return &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(newSVpv(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);
@@ -202,7 +233,7 @@ hv_fetch_ent(HV *hv, SV *keysv, I32 lval, register U32 hash)
     if (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME)) {
       char *gotenv;
 
-      if ((gotenv = ENV_getenv(key)) != Nullch) {
+      if ((gotenv = PerlEnv_getenv(key)) != Nullch) {
         sv = newSVpv(gotenv,strlen(gotenv));
         SvTAINTED_on(sv);
         return hv_store_ent(hv,keysv,sv,hash);
@@ -216,6 +247,25 @@ hv_fetch_ent(HV *hv, SV *keysv, I32 lval, register U32 hash)
     return 0;
 }
 
+static void
+hv_magic_check (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 *hv, char *key, U32 klen, SV *val, register U32 hash)
 {
@@ -229,15 +279,21 @@ hv_store(HV *hv, char *key, U32 klen, SV *val, 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(newSVpv(key,klen));
+		key = strupr(SvPVX(sv));
+		hash = 0;
+	    }
+#endif
+	}
     }
     if (!hash)
 	PERL_HASH(hash, key, klen);
@@ -295,24 +351,31 @@ hv_store_ent(HV *hv, SV *keysv, SV *val, register U32 hash)
     xhv = (XPVHV*)SvANY(hv);
     if (SvMAGICAL(hv)) {
 	dTHR;
-	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;
+ 	bool needs_copy;
+ 	bool needs_store;
+ 	hv_magic_check (hv, &needs_copy, &needs_store);
+ 	if (needs_copy) {
+ 	    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 && !needs_store)
+ 		return Nullhe;
+#ifdef ENV_IS_CASELESS
+	    else if (mg_find((SV*)hv,'E')) {
+		key = SvPV(keysv, klen);
+		keysv = sv_2mortal(newSVpv(key,klen));
+		(void)strupr(SvPVX(keysv));
+		hash = 0;
+	    }
+#endif
+	}
     }
 
     key = SvPV(keysv, klen);
-    
+
     if (!hash)
 	PERL_HASH(hash, key, klen);
 
@@ -361,20 +424,33 @@ hv_delete(HV *hv, char *key, U32 klen, I32 flags)
     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(newSVpv(key,klen));
+		key = strupr(SvPVX(sv));
+	    }
+#endif
+        }
     }
     xhv = (XPVHV*)SvANY(hv);
     if (!xhv->xhv_array)
@@ -423,12 +499,28 @@ hv_delete_ent(HV *hv, SV *keysv, I32 flags, 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(newSVpv(key,klen));
+		(void)strupr(SvPVX(keysv));
+		hash = 0; 
+	    }
+#endif
 	}
     }
     xhv = (XPVHV*)SvANY(hv);
@@ -486,6 +578,12 @@ hv_exists(HV *hv, char *key, U32 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(newSVpv(key,klen));
+	    key = strupr(SvPVX(sv));
+	}
+#endif
     }
 
     xhv = (XPVHV*)SvANY(hv);
@@ -529,6 +627,14 @@ hv_exists_ent(HV *hv, SV *keysv, U32 hash)
 	    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(newSVpv(key,klen));
+	    (void)strupr(SvPVX(keysv));
+	    hash = 0; 
+	}
+#endif
     }
 
     xhv = (XPVHV*)SvANY(hv);
@@ -552,7 +658,7 @@ hv_exists_ent(HV *hv, SV *keysv, U32 hash)
     return FALSE;
 }
 
-static void
+STATIC void
 hsplit(HV *hv)
 {
     register XPVHV* xhv = (XPVHV*)SvANY(hv);
@@ -571,6 +677,10 @@ hsplit(HV *hv)
     nomemok = TRUE;
 #ifdef STRANGE_MALLOC
     Renew(a, newsize, HE*);
+    if (!a) {
+      nomemok = FALSE;
+      return;
+    }
 #else
     i = newsize * sizeof(HE*);
 #define MALLOC_OVERHEAD 16
@@ -581,6 +691,10 @@ hsplit(HV *hv)
     tmp /= sizeof(HE*);
     assert(tmp >= newsize);
     New(2,a, tmp, HE*);
+    if (!a) {
+      nomemok = FALSE;
+      return;
+    }
     Copy(xhv->xhv_array, a, oldsize, HE*);
     if (oldsize >= 64) {
 	offer_nice_chunk(xhv->xhv_array,
@@ -644,6 +758,10 @@ hv_ksplit(HV *hv, IV newmax)
 	nomemok = TRUE;
 #ifdef STRANGE_MALLOC
 	Renew(a, newsize, HE*);
+        if (!a) {
+	  nomemok = FALSE;
+	  return;
+	}
 #else
 	i = newsize * sizeof(HE*);
 	j = MALLOC_OVERHEAD;
@@ -653,6 +771,10 @@ hv_ksplit(HV *hv, IV newmax)
 	j /= sizeof(HE*);
 	assert(j >= newsize);
 	New(2, a, j, HE*);
+        if (!a) {
+	  nomemok = FALSE;
+	  return;
+	}
 	Copy(xhv->xhv_array, a, oldsize, HE*);
 	if (oldsize >= 64) {
 	    offer_nice_chunk(xhv->xhv_array,
@@ -716,11 +838,14 @@ newHV(void)
 void
 hv_free_ent(HV *hv, register HE *entry)
 {
+    SV *val;
+
     if (!entry)
 	return;
-    if (isGV(HeVAL(entry)) && GvCVu(HeVAL(entry)) && HvNAME(hv))
+    val = HeVAL(entry);
+    if (val && isGV(val) && GvCVu(val) && HvNAME(hv))
 	sub_generation++;	/* may be deletion of method from stash */
-    SvREFCNT_dec(HeVAL(entry));
+    SvREFCNT_dec(val);
     if (HeKLEN(entry) == HEf_SVKEY) {
 	SvREFCNT_dec(HeKEY_sv(entry));
         Safefree(HeKEY_hek(entry));
@@ -768,7 +893,7 @@ hv_clear(HV *hv)
 	mg_clear((SV*)hv); 
 }
 
-static void
+STATIC void
 hfreeentries(HV *hv)
 {
     register HE **array;
@@ -843,7 +968,7 @@ hv_iterinit(HV *hv)
     }
     xhv->xhv_riter = -1;
     xhv->xhv_eiter = Null(HE*);
-    return xhv->xhv_fill;	/* should be xhv->xhv_keys? May change later */
+    return xhv->xhv_keys;	/* used to be xhv->xhv_fill before 5.004_65 */
 }
 
 HE *
@@ -1068,3 +1193,4 @@ share_hek(char *str, I32 len, register U32 hash)
 }
 
 
+