diff options
| -rw-r--r-- | embed.fnc | 2 | ||||
| -rw-r--r-- | embed.h | 2 | ||||
| -rw-r--r-- | hv.c | 88 | ||||
| -rw-r--r-- | proto.h | 12 |
4 files changed, 104 insertions, 0 deletions
@@ -2110,6 +2110,8 @@ ApoR |HE** |hv_eiter_p |NN HV *hv Apo |void |hv_riter_set |NN HV *hv|I32 riter Apo |void |hv_eiter_set |NN HV *hv|NULLOK HE *eiter Ap |void |hv_name_set |NN HV *hv|NULLOK const char *name|U32 len|U32 flags +p |void |hv_name_add |NN HV *hv|NN const char *name|U32 len +p |void |hv_name_delete |NN HV *hv|NN const char *name|U32 len : Used in dump.c and hv.c poM |AV** |hv_backreferences_p |NN HV *hv #if defined(PERL_IN_DUMP_C) || defined(PERL_IN_HV_C) || defined(PERL_IN_SV_C) @@ -987,6 +987,8 @@ #define get_no_modify() Perl_get_no_modify(aTHX) #define get_opargs() Perl_get_opargs(aTHX) #define gv_try_downgrade(a) Perl_gv_try_downgrade(aTHX_ a) +#define hv_name_add(a,b,c) Perl_hv_name_add(aTHX_ a,b,c) +#define hv_name_delete(a,b,c) Perl_hv_name_delete(aTHX_ a,b,c) #define init_argv_symbols(a,b) Perl_init_argv_symbols(aTHX_ a,b) #define init_debugger() Perl_init_debugger(aTHX) #define intro_my() Perl_intro_my(aTHX) @@ -2048,6 +2048,94 @@ Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags) iter->xhv_name_count = 0; } +void +Perl_hv_name_add(pTHX_ HV *hv, const char *name, U32 len) +{ + dVAR; + struct xpvhv_aux *aux = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv); + U32 hash; + + PERL_ARGS_ASSERT_HV_NAME_ADD; + + if (len > I32_MAX) + Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len); + + PERL_HASH(hash, name, len); + + if (!aux->xhv_name) { + aux->xhv_name = share_hek(name, len, hash); + return; + } + + if (aux->xhv_name_count) { + HEK ** const xhv_name = (HEK **)aux->xhv_name; + HEK **hekp = xhv_name + aux->xhv_name_count; + U32 count = aux->xhv_name_count; + while (hekp-- > xhv_name) + if ( + HEK_LEN(*hekp) == (I32)len && memEQ(HEK_KEY(*hekp), name, len) + ) return; + Renewc(aux->xhv_name, ++aux->xhv_name_count, HEK *, HEK); + ((HEK **)aux->xhv_name)[count] = share_hek(name, len, hash); + } + else { + HEK *existing_name = aux->xhv_name; + if ( + HEK_LEN(existing_name) == (I32)len + && memEQ(HEK_KEY(existing_name), name, len) + ) return; + Newxc(aux->xhv_name, 2, HEK *, HEK); + *(HEK **)aux->xhv_name = existing_name; + ((HEK **)aux->xhv_name)[1] = share_hek(name, len, hash); + } +} + +void +Perl_hv_name_delete(pTHX_ HV *hv, const char *name, U32 len) +{ + dVAR; + struct xpvhv_aux *aux; + + PERL_ARGS_ASSERT_HV_NAME_DELETE; + + if (len > I32_MAX) + Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len); + + if (!SvOOK(hv)) return; + + aux = HvAUX(hv); + if (!aux->xhv_name) return; + + if (aux->xhv_name_count) { + HEK ** const namep = (HEK **)aux->xhv_name; + HEK **victim = namep + aux->xhv_name_count; + while (victim-- > namep) + if ( + HEK_LEN(*victim) == (I32)len + && memEQ(HEK_KEY(*victim), name, len) + ) { + unshare_hek_or_pvn(*victim, 0, 0, 0); + if (!--aux->xhv_name_count) { /* none left */ + Safefree(namep); + aux->xhv_name = NULL; + } + else { + /* Move the last one back to fill the empty slot. It + does not matter what order they are in. */ + *victim = *(namep + aux->xhv_name_count); + } + return; + } + } + else if( + HEK_LEN(aux->xhv_name) == (I32)len + && memEQ(HEK_KEY(aux->xhv_name), name, len) + ) { + unshare_hek_or_pvn(aux->xhv_name, 0, 0, 0); + aux->xhv_name = NULL; + } +} + AV ** Perl_hv_backreferences_p(pTHX_ HV *hv) { struct xpvhv_aux * const iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv); @@ -1344,6 +1344,18 @@ PERL_CALLCONV void Perl_hv_ksplit(pTHX_ HV *hv, IV newmax) #define PERL_ARGS_ASSERT_HV_MAGIC \ assert(hv) +PERL_CALLCONV void Perl_hv_name_add(pTHX_ HV *hv, const char *name, U32 len) + __attribute__nonnull__(pTHX_1) + __attribute__nonnull__(pTHX_2); +#define PERL_ARGS_ASSERT_HV_NAME_ADD \ + assert(hv); assert(name) + +PERL_CALLCONV void Perl_hv_name_delete(pTHX_ HV *hv, const char *name, U32 len) + __attribute__nonnull__(pTHX_1) + __attribute__nonnull__(pTHX_2); +#define PERL_ARGS_ASSERT_HV_NAME_DELETE \ + assert(hv); assert(name) + PERL_CALLCONV void Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_HV_NAME_SET \ |