provide EBCDIC CGI::Util::escape() and test

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

diff --git a/hv.c b/hv.c
index 334f7ad..c999488 100644 (file)
--- a/hv.c
+++ b/hv.c
@@ -1,6 +1,6 @@
 /*    hv.c
  *
- *    Copyright (c) 1991-2000, Larry Wall
+ *    Copyright (c) 1991-2001, 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.
@@ -94,7 +94,8 @@ S_save_hek(pTHX_ const char *str, I32 len, U32 hash)
 void
 Perl_unshare_hek(pTHX_ HEK *hek)
 {
-    unsharepvn(HEK_KEY(hek),HEK_LEN(hek),HEK_HASH(hek));
+    unsharepvn(HEK_KEY(hek),HEK_UTF8(hek)?-HEK_LEN(hek):HEK_LEN(hek),
+               HEK_HASH(hek));
 }
 
 #if defined(USE_ITHREADS)
@@ -118,9 +119,9 @@ Perl_he_dup(pTHX_ HE *e, bool 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_UTF8(e), HeHASH(e));
+       HeKEY_hek(ret) = share_hek(HeKEY(e), HeKLEN_UTF8(e), HeHASH(e));
     else
- HeKEY_hek(ret) = save_hek(HeKEY(e), HeKLEN_UTF8(e), HeHASH(e));
+       HeKEY_hek(ret) = save_hek(HeKEY(e), HeKLEN_UTF8(e), HeHASH(e));
     HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e)));
     return ret;
 }
@@ -151,6 +152,7 @@ Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen, I32 lval)
     register HE *entry;
     SV *sv;
     bool is_utf8 = FALSE;
+    const char *keysave = key;
 
     if (!hv)
        return 0;
@@ -195,6 +197,9 @@ Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen, I32 lval)
            return 0;
     }
 
+    if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
+       key = (char*)bytes_from_utf8((U8*)key, (STRLEN*)&klen, &is_utf8);
+
     PERL_HASH(hash, key, klen);
 
     entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
@@ -205,8 +210,10 @@ Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen, I32 lval)
            continue;
        if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
            continue;
- if (HeKUTF8(entry) != (char)is_utf8)
-     continue;
+       if (HeKUTF8(entry) != (char)is_utf8)
+           continue;
+       if (key != keysave)
+           Safefree(key);
        return &HeVAL(entry);
     }
 #ifdef DYNAMIC_ENV_FETCH  /* %ENV lookup?  If so, try to fetch the value now */
@@ -216,14 +223,24 @@ Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen, I32 lval)
        if (env) {
            sv = newSVpvn(env,len);
            SvTAINTED_on(sv);
+           if (key != keysave)
+               Safefree(key);
            return hv_store(hv,key,klen,sv,hash);
        }
     }
 #endif
     if (lval) {                /* gonna assign to this, so it better be there */
        sv = NEWSV(61,0);
- return hv_store(hv,key,is_utf8?-klen:klen,sv,hash);
+       if (key != keysave) { /* must be is_utf8 == 0 */
+           SV **ret = hv_store(hv,key,klen,sv,hash);
+           Safefree(key);
+           return ret;
+       }
+       else
+           return hv_store(hv,key,is_utf8?-klen:klen,sv,hash);
     }
+    if (key != keysave)
+       Safefree(key);
     return 0;
 }
 
@@ -255,6 +272,7 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
     register HE *entry;
     SV *sv;
     bool is_utf8;
+    char *keysave;
 
     if (!hv)
        return 0;
@@ -303,9 +321,12 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
            return 0;
     }
 
-    key = SvPV(keysv, klen);
+    keysave = key = SvPV(keysv, klen);
     is_utf8 = (SvUTF8(keysv)!=0);
 
+    if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
+       key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
+
     if (!hash)
        PERL_HASH(hash, key, klen);
 
@@ -317,8 +338,10 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
            continue;
        if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
            continue;
- if (HeKUTF8(entry) != (char)is_utf8)
-     continue;
+       if (HeKUTF8(entry) != (char)is_utf8)
+           continue;
+       if (key != keysave)
+           Safefree(key);
        return entry;
     }
 #ifdef DYNAMIC_ENV_FETCH  /* %ENV lookup?  If so, try to fetch the value now */
@@ -332,6 +355,8 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
        }
     }
 #endif
+    if (key != keysave)
+       Safefree(key);
     if (lval) {                /* gonna assign to this, so it better be there */
        sv = NEWSV(61,0);
        return hv_store_ent(hv,keysv,sv,hash);
@@ -384,6 +409,7 @@ Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, register U32 has
     register HE *entry;
     register HE **oentry;
     bool is_utf8 = FALSE;
+    const char *keysave = key;
 
     if (!hv)
        return 0;
@@ -411,6 +437,9 @@ Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, register U32 has
 #endif
        }
     }
+    if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
+       key = (char*)bytes_from_utf8((U8*)key, (STRLEN*)&klen, &is_utf8);
+
     if (!hash)
        PERL_HASH(hash, key, klen);
 
@@ -428,18 +457,22 @@ Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, register U32 has
            continue;
        if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
            continue;
- if (HeKUTF8(entry) != (char)is_utf8)
-     continue;
+       if (HeKUTF8(entry) != (char)is_utf8)
+           continue;
        SvREFCNT_dec(HeVAL(entry));
        HeVAL(entry) = val;
+       if (key != keysave)
+           Safefree(key);
        return &HeVAL(entry);
     }
 
     entry = new_HE();
     if (HvSHAREKEYS(hv))
- HeKEY_hek(entry) = share_hek(key, is_utf8?-klen:klen, hash);
+       HeKEY_hek(entry) = share_hek(key, is_utf8?-klen:klen, hash);
     else                                       /* gotta do the real thing */
- HeKEY_hek(entry) = save_hek(key, is_utf8?-klen:klen, hash);
+       HeKEY_hek(entry) = save_hek(key, is_utf8?-klen:klen, hash);
+    if (key != keysave)
+       Safefree(key);
     HeVAL(entry) = val;
     HeNEXT(entry) = *oentry;
     *oentry = entry;
@@ -483,6 +516,7 @@ Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash)
     register HE *entry;
     register HE **oentry;
     bool is_utf8;
+    char *keysave;
 
     if (!hv)
        return 0;
@@ -512,9 +546,12 @@ Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash)
        }
     }
 
-    key = SvPV(keysv, klen);
+    keysave = key = SvPV(keysv, klen);
     is_utf8 = (SvUTF8(keysv) != 0);
 
+    if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
+       key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
+
     if (!hash)
        PERL_HASH(hash, key, klen);
 
@@ -532,18 +569,22 @@ Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash)
            continue;
        if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
            continue;
- if (HeKUTF8(entry) != (char)is_utf8)
-     continue;
+       if (HeKUTF8(entry) != (char)is_utf8)
+           continue;
        SvREFCNT_dec(HeVAL(entry));
        HeVAL(entry) = val;
+       if (key != keysave)
+           Safefree(key);
        return entry;
     }
 
     entry = new_HE();
     if (HvSHAREKEYS(hv))
- HeKEY_hek(entry) = share_hek(key, is_utf8?-klen:klen, hash);
+       HeKEY_hek(entry) = share_hek(key, is_utf8?-klen:klen, hash);
     else                                       /* gotta do the real thing */
- HeKEY_hek(entry) = save_hek(key, is_utf8?-klen:klen, hash);
+       HeKEY_hek(entry) = save_hek(key, is_utf8?-klen:klen, hash);
+    if (key != keysave)
+       Safefree(key);
     HeVAL(entry) = val;
     HeNEXT(entry) = *oentry;
     *oentry = entry;
@@ -580,6 +621,7 @@ Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags)
     SV **svp;
     SV *sv;
     bool is_utf8 = FALSE;
+    const char *keysave = key;
 
     if (!hv)
        return Nullsv;
@@ -614,6 +656,9 @@ Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags)
     if (!xhv->xhv_array)
        return Nullsv;
 
+    if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
+       key = (char*)bytes_from_utf8((U8*)key, (STRLEN*)&klen, &is_utf8);
+
     PERL_HASH(hash, key, klen);
 
     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
@@ -626,8 +671,10 @@ Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags)
            continue;
        if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
            continue;
- if (HeKUTF8(entry) != (char)is_utf8)
-     continue;
+       if (HeKUTF8(entry) != (char)is_utf8)
+           continue;
+       if (key != keysave)
+           Safefree(key);
        *oentry = HeNEXT(entry);
        if (i && !*oentry)
            xhv->xhv_fill--;
@@ -644,6 +691,8 @@ Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags)
        --xhv->xhv_keys;
        return sv;
     }
+    if (key != keysave)
+       Safefree(key);
     return Nullsv;
 }
 
@@ -669,6 +718,7 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
     register HE **oentry;
     SV *sv;
     bool is_utf8;
+    char *keysave;
 
     if (!hv)
        return Nullsv;
@@ -701,9 +751,12 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
     if (!xhv->xhv_array)
        return Nullsv;
 
-    key = SvPV(keysv, klen);
+    keysave = key = SvPV(keysv, klen);
     is_utf8 = (SvUTF8(keysv) != 0);
 
+    if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
+       key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
+
     if (!hash)
        PERL_HASH(hash, key, klen);
 
@@ -717,8 +770,10 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
            continue;
        if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
            continue;
- if (HeKUTF8(entry) != (char)is_utf8)
-     continue;
+       if (HeKUTF8(entry) != (char)is_utf8)
+           continue;
+       if (key != keysave)
+           Safefree(key);
        *oentry = HeNEXT(entry);
        if (i && !*oentry)
            xhv->xhv_fill--;
@@ -735,6 +790,8 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
        --xhv->xhv_keys;
        return sv;
     }
+    if (key != keysave)
+       Safefree(key);
     return Nullsv;
 }
 
@@ -755,6 +812,7 @@ Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen)
     register HE *entry;
     SV *sv;
     bool is_utf8 = FALSE;
+    const char *keysave = key;
 
     if (!hv)
        return 0;
@@ -785,6 +843,9 @@ Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen)
        return 0;
 #endif
 
+    if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
+       key = (char*)bytes_from_utf8((U8*)key, (STRLEN*)&klen, &is_utf8);
+
     PERL_HASH(hash, key, klen);
 
 #ifdef DYNAMIC_ENV_FETCH
@@ -799,8 +860,10 @@ Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen)
            continue;
        if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
            continue;
- if (HeKUTF8(entry) != (char)is_utf8)
-     continue;
+       if (HeKUTF8(entry) != (char)is_utf8)
+           continue;
+       if (key != keysave)
+           Safefree(key);
        return TRUE;
     }
 #ifdef DYNAMIC_ENV_FETCH  /* is it out there? */
@@ -815,6 +878,8 @@ Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen)
        }
     }
 #endif
+    if (key != keysave)
+       Safefree(key);
     return FALSE;
 }
 
@@ -837,6 +902,8 @@ Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
     STRLEN klen;
     register HE *entry;
     SV *sv;
+    bool is_utf8;
+    char *keysave;
 
     if (!hv)
        return 0;
@@ -865,7 +932,10 @@ Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
        return 0;
 #endif
 
-    key = SvPV(keysv, klen);
+    keysave = key = SvPV(keysv, klen);
+    is_utf8 = (SvUTF8(keysv) != 0);
+    if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
+       key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
     if (!hash)
        PERL_HASH(hash, key, klen);
 
@@ -881,6 +951,10 @@ Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
            continue;
        if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen))        /* is this it? */
            continue;
+       if (HeKUTF8(entry) != (char)is_utf8)
+           continue;
+       if (key != keysave)
+           Safefree(key);
        return TRUE;
     }
 #ifdef DYNAMIC_ENV_FETCH  /* is it out there? */
@@ -895,6 +969,8 @@ Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
        }
     }
 #endif
+    if (key != keysave)
+       Safefree(key);
     return FALSE;
 }
 
@@ -1095,8 +1171,8 @@ Perl_newHVhv(pTHX_ HV *ohv)
        /* Slow way */
        hv_iterinit(ohv);
        while ((entry = hv_iternext(ohv))) {
-     hv_store(hv, HeKEY(entry), HeKLEN_UTF8(entry),
-                    SvREFCNT_inc(HeVAL(entry)), HeHASH(entry));
+           hv_store(hv, HeKEY(entry), HeKLEN_UTF8(entry),
+                    newSVsv(HeVAL(entry)), HeHASH(entry));
        }
        HvRITER(ohv) = hv_riter;
        HvEITER(ohv) = hv_eiter;
@@ -1386,13 +1462,9 @@ Perl_hv_iterkeysv(pTHX_ register HE *entry)
 {
     if (HeKLEN(entry) == HEf_SVKEY)
        return sv_mortalcopy(HeKEY_sv(entry));
-    else {
-        SV *sv = newSVpvn_share((HeKLEN(entry) ? HeKEY(entry) : ""),
-    HeKLEN(entry), HeHASH(entry));
- if (HeKUTF8(entry))
-     SvUTF8_on(sv);
- return sv_2mortal(sv);
-    }
+    else
+       return sv_2mortal(newSVpvn_share((HeKLEN(entry) ? HeKEY(entry) : ""),
+                                        HeKLEN_UTF8(entry), HeHASH(entry)));
 }
 
 /*
@@ -1469,6 +1541,15 @@ Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
     register HE **oentry;
     register I32 i = 1;
     I32 found = 0;
+    bool is_utf8 = FALSE;
+    const char *save = str;
+
+    if (len < 0) {
+      len = -len;
+      is_utf8 = TRUE;
+      if (!(PL_hints & HINT_UTF8_DISTINCT))
+         str = (char*)bytes_from_utf8((U8*)str, (STRLEN*)&len, &is_utf8);
+    }
 
     /* what follows is the moral equivalent of:
     if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
@@ -1486,6 +1567,8 @@ Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
            continue;
        if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
            continue;
+       if (HeKUTF8(entry) != (char)is_utf8)
+           continue;
        found = 1;
        if (--HeVAL(entry) == Nullsv) {
            *oentry = HeNEXT(entry);
@@ -1498,7 +1581,8 @@ Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
        break;
     }
     UNLOCK_STRTAB_MUTEX;
-
+    if (str != save)
+       Safefree(str);
     if (!found && ckWARN_d(WARN_INTERNAL))
        Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free non-existent shared string '%s'",str);
 }
@@ -1516,10 +1600,13 @@ Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
     register I32 i = 1;
     I32 found = 0;
     bool is_utf8 = FALSE;
+    const char *save = str;
 
     if (len < 0) {
       len = -len;
       is_utf8 = TRUE;
+      if (!(PL_hints & HINT_UTF8_DISTINCT))
+         str = (char*)bytes_from_utf8((U8*)str, (STRLEN*)&len, &is_utf8);
     }
 
     /* what follows is the moral equivalent of:
@@ -1538,14 +1625,14 @@ Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
            continue;
        if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
            continue;
- if (HeKUTF8(entry) != (char)is_utf8)
-     continue;
+       if (HeKUTF8(entry) != (char)is_utf8)
+           continue;
        found = 1;
        break;
     }
     if (!found) {
        entry = new_HE();
- HeKEY_hek(entry) = save_hek(str, is_utf8?-len:len, hash);
+       HeKEY_hek(entry) = save_hek(str, is_utf8?-len:len, hash);
        HeVAL(entry) = Nullsv;
        HeNEXT(entry) = *oentry;
        *oentry = entry;
@@ -1559,8 +1646,7 @@ Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
 
     ++HeVAL(entry);                            /* use value slot as REFCNT */
     UNLOCK_STRTAB_MUTEX;
+    if (str != save)
+       Safefree(str);
     return HeKEY_hek(entry);
 }
-
-
-