he = (HE*) Perl_get_arena(aTHX_ PERL_ARENA_SIZE);
heend = &he[PERL_ARENA_SIZE / sizeof(HE) - 1];
- PL_body_roots[HE_SVSLOT] = ++he;
+ PL_body_roots[HE_SVSLOT] = he;
while (he < heend) {
HeNEXT(he) = (HE*)(he + 1);
he++;
if (!*root)
S_more_he(aTHX);
he = *root;
+ assert(he);
*root = HeNEXT(he);
UNLOCK_SV_MUTEX;
return he;
he = HeNEXT(he);
del_HE(ohe);
}
- PL_hv_fetch_ent_mh = Nullhe;
+ PL_hv_fetch_ent_mh = NULL;
}
#if defined(USE_ITHREADS)
HE *ret;
if (!e)
- return Nullhe;
+ return NULL;
/* look for it in the table first */
ret = (HE*)ptr_table_fetch(PL_ptr_table, e);
if (ret)
Newx(k, HEK_BASESIZE + sizeof(SV*), char);
HeKEY_hek(entry) = (HEK*)k;
}
- HeNEXT(entry) = Nullhe;
+ HeNEXT(entry) = NULL;
HeSVKEY_set(entry, keysv);
HeVAL(entry) = sv;
sv_upgrade(sv, SVt_PVLV);
}
TAINT_IF(save_taint);
- if (!HvARRAY(hv) && !needs_store) {
+ if (!needs_store) {
if (flags & HVhek_FREEKEY)
Safefree(key);
- return Nullhe;
+ return NULL;
}
#ifdef ENV_IS_CASELESS
else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
masked_flags = (flags & HVhek_MASK);
#ifdef DYNAMIC_ENV_FETCH
- if (!HvARRAY(hv)) entry = Null(HE*);
+ if (!HvARRAY(hv)) entry = NULL;
else
#endif
{
{
const HE *counter = HeNEXT(entry);
- xhv->xhv_keys++; /* HvKEYS(hv)++ */
+ xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
if (!counter) { /* initial entry? */
xhv->xhv_fill++; /* HvFILL(hv)++ */
} else if (xhv->xhv_keys > (IV)xhv->xhv_max) {
}
STATIC void
-S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store)
+S_hv_magic_check(HV *hv, bool *needs_copy, bool *needs_store)
{
const MAGIC *mg = SvMAGIC(hv);
*needs_copy = FALSE;
return NULL;
}
if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
- S_hv_notallowed(aTHX_ k_flags, key, klen,
+ hv_notallowed(k_flags, key, klen,
"Attempt to delete readonly key '%"SVf"' from"
" a restricted hash");
}
HvLAZYDEL_on(hv);
else
hv_free_ent(hv, entry);
- xhv->xhv_keys--; /* HvKEYS(hv)-- */
+ xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
if (xhv->xhv_keys == 0)
HvHASKFLAGS_off(hv);
}
return sv;
}
if (SvREADONLY(hv)) {
- S_hv_notallowed(aTHX_ k_flags, key, klen,
+ hv_notallowed(k_flags, key, klen,
"Attempt to delete disallowed key '%"SVf"' from"
" a restricted hash");
}
return hv;
}
+/* A rather specialised version of newHVhv for copying %^H, ensuring all the
+ magic stays on it. */
+HV *
+Perl_hv_copy_hints_hv(pTHX_ HV *const ohv)
+{
+ HV * const hv = newHV();
+ STRLEN hv_fill;
+
+ if (ohv && (hv_fill = HvFILL(ohv))) {
+ STRLEN hv_max = HvMAX(ohv);
+ HE *entry;
+ const I32 riter = HvRITER_get(ohv);
+ HE * const eiter = HvEITER_get(ohv);
+
+ while (hv_max && hv_max + 1 >= hv_fill * 2)
+ hv_max = hv_max / 2;
+ HvMAX(hv) = hv_max;
+
+ hv_iterinit(ohv);
+ while ((entry = hv_iternext_flags(ohv, 0))) {
+ SV *const sv = newSVsv(HeVAL(entry));
+ sv_magic(sv, NULL, PERL_MAGIC_hintselem,
+ (char *)newSVhek (HeKEY_hek(entry)), HEf_SVKEY);
+ hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
+ sv, HeHASH(entry), HeKFLAGS(entry));
+ }
+ HvRITER_set(ohv, riter);
+ HvEITER_set(ohv, eiter);
+ }
+ hv_magic(hv, NULL, PERL_MAGIC_hints);
+ return hv;
+}
+
void
Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
{
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;
Perl_hv_clear_placeholders(pTHX_ HV *hv)
{
dVAR;
- I32 items = (I32)HvPLACEHOLDERS_get(hv);
+ const U32 items = (U32)HvPLACEHOLDERS_get(hv);
+
+ if (items)
+ clear_placeholders(hv, items);
+}
+
+static void
+S_clear_placeholders(pTHX_ HV *hv, U32 items)
+{
+ dVAR;
I32 i;
if (items == 0)
hv_free_ent(hv, entry);
}
iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
- iter->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
+ iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
/* There are now no allocated pointers in the aux structure. */
iter = HvAUX(hv);
iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
- iter->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
+ iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
iter->xhv_name = 0;
iter->xhv_backreferences = 0;
return iter;
hv_free_ent(hv, entry);
}
iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
- iter->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
+ iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
} else {
hv_auxinit(hv);
}
}
void
-Perl_hv_name_set(pTHX_ HV *hv, const char *name, I32 len, int flags)
+Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
{
dVAR;
struct xpvhv_aux *iter;
PERL_UNUSED_ARG(flags);
+ if (len > I32_MAX)
+ Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
+
if (SvOOK(hv)) {
iter = HvAUX(hv);
if (iter->xhv_name) {
AV **
Perl_hv_backreferences_p(pTHX_ HV *hv) {
struct xpvhv_aux * const iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
+ PERL_UNUSED_CONTEXT;
return &(iter->xhv_backreferences);
}
magic_nextpack((SV*) hv,mg,key);
if (SvOK(key)) {
/* force key to stay around until next time */
- HeSVKEY_set(entry, SvREFCNT_inc(key));
+ HeSVKEY_set(entry, SvREFCNT_inc_simple_NN(key));
return entry; /* beware, hent_val is not set */
}
if (HeVAL(entry))
SvREFCNT_dec(HeVAL(entry));
Safefree(HeKEY_hek(entry));
del_HE(entry);
- iter->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
- return Null(HE*);
+ 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
HE *entry;
register HE **oentry;
HE **first;
- bool found = 0;
bool is_utf8 = FALSE;
int k_flags = 0;
const char * const save = str;
if (he) {
const HE *const he_he = &(he->shared_he_he);
for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
- if (entry != he_he)
- continue;
- found = 1;
- break;
+ if (entry == he_he)
+ break;
}
} else {
const int flags_masked = k_flags & HVhek_MASK;
continue;
if (HeKFLAGS(entry) != flags_masked)
continue;
- found = 1;
break;
}
}
- if (found) {
- if (--he->shared_he_he.he_valu.hent_refcount == 0) {
+ if (entry) {
+ if (--entry->he_valu.hent_refcount == 0) {
*oentry = HeNEXT(entry);
if (!*first) {
/* There are now no entries in our slot. */
xhv->xhv_fill--; /* HvFILL(hv)-- */
}
Safefree(entry);
- xhv->xhv_keys--; /* HvKEYS(hv)-- */
+ xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
}
}
UNLOCK_STRTAB_MUTEX;
- if (!found && ckWARN_d(WARN_INTERNAL))
+ if (!entry && ckWARN_d(WARN_INTERNAL))
Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
"Attempt to free non-existent shared string '%s'%s"
pTHX__FORMAT,
HeNEXT(entry) = next;
*head = entry;
- xhv->xhv_keys++; /* HvKEYS(hv)++ */
+ xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
if (!next) { /* initial entry? */
xhv->xhv_fill++; /* HvFILL(hv)++ */
} else if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) {
}
/*
+=for apidoc refcounted_he_chain_2hv
+
+Generates an returns a C<HV *> by walking up the tree starting at the passed
+in C<struct refcounted_he *>.
+
+=cut
+*/
+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,
+ and call ksplit. But for now we'll make a potentially inefficient
+ hash with only 8 entries in its array. */
+ const U32 max = HvMAX(hv);
+
+ if (!HvARRAY(hv)) {
+ char *array;
+ Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(max + 1), char);
+ HvARRAY(hv) = (HE**)array;
+ }
+
+ while (chain) {
+#ifdef USE_ITHREADS
+ U32 hash = chain->refcounted_he_hash;
+#else
+ U32 hash = HEK_HASH(chain->refcounted_he_hek);
+#endif
+ HE **oentry = &((HvARRAY(hv))[hash & max]);
+ HE *entry = *oentry;
+ SV *value;
+
+ for (; entry; entry = HeNEXT(entry)) {
+ if (HeHASH(entry) == hash) {
+ goto next_please;
+ }
+ }
+ assert (!entry);
+ entry = new_HE();
+
+#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,
+ chain->refcounted_he_keylen,
+ chain->refcounted_he_hash,
+ (chain->refcounted_he_data[0]
+ & (HVhek_UTF8|HVhek_WASUTF8)));
+#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;
+ 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. */
+ HeNEXT(entry) = *oentry;
+ if (!HeNEXT(entry)) {
+ /* initial entry. */
+ HvFILL(hv)++;
+ }
+ *oentry = entry;
+
+ HvTOTALKEYS(hv)++;
+
+ next_please:
+ chain = chain->refcounted_he_next;
+ }
+
+ if (placeholders) {
+ clear_placeholders(hv, placeholders);
+ HvTOTALKEYS(hv) -= placeholders;
+ }
+
+ /* We could check in the loop to see if we encounter any keys with key
+ flags, but it's probably not worth it, as this per-hash flag is only
+ really meant as an optimisation for things like Storable. */
+ HvHASKFLAGS_on(hv);
+ DEBUG_A(Perl_hv_assert(aTHX_ hv));
+
+ return hv;
+}
+
+/*
+=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.
+
+=cut
+*/
+
+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 = NULL;
+ char value_type;
+ char flags;
+ STRLEN key_offset;
+ U32 hash;
+ bool is_utf8 = SvUTF8(key);
+
+ if (SvPOK(value)) {
+ value_type = HVrhek_PV;
+ } else if (SvIOK(value)) {
+ value_type = HVrhek_IV;
+ } else if (value == &PL_sv_placeholder) {
+ value_type = HVrhek_delete;
+ } else if (!SvOK(value)) {
+ value_type = HVrhek_undef;
+ } else {
+ value_type = HVrhek_PV;
+ }
+
+ if (value_type == HVrhek_PV) {
+ value_p = SvPV_const(value, value_len);
+ key_offset = value_len + 2;
+ } else {
+ value_len = 0;
+ key_offset = 1;
+ }
+ flags = value_type;
+
+#ifdef USE_ITHREADS
+ he = PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
+ + key_len
+ + key_offset);
+#else
+ he = PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
+ + key_offset);
+#endif
+
+
+ he->refcounted_he_next = parent;
+
+ if (value_type == HVrhek_PV) {
+ Copy(value_p, he->refcounted_he_data + 1, value_len + 1, char);
+ he->refcounted_he_val.refcounted_he_u_len = value_len;
+ if (SvUTF8(value)) {
+ flags |= HVrhek_UTF8;
+ }
+ } else if (value_type == HVrhek_IV) {
+ if (SvUOK(value)) {
+ he->refcounted_he_val.refcounted_he_u_uv = SvUVX(value);
+ flags |= HVrhek_UV;
+ } else {
+ he->refcounted_he_val.refcounted_he_u_iv = SvIVX(value);
+ }
+ }
+
+ if (is_utf8) {
+ /* Hash keys are always stored normalised to (yes) ISO-8859-1.
+ As we're going to be building hash keys from this value in future,
+ normalise it now. */
+ key_p = (char*)bytes_from_utf8((const U8*)key_p, &key_len, &is_utf8);
+ flags |= is_utf8 ? HVhek_UTF8 : HVhek_WASUTF8;
+ }
+ PERL_HASH(hash, key_p, key_len);
+
+#ifdef USE_ITHREADS
+ he->refcounted_he_hash = hash;
+ he->refcounted_he_keylen = key_len;
+ Copy(key_p, he->refcounted_he_data + key_offset, key_len, char);
+#else
+ he->refcounted_he_hek = share_hek_flags(key_p, key_len, hash, flags);
+#endif
+
+ if (flags & HVhek_WASUTF8) {
+ /* If it was downgraded from UTF-8, then the pointer returned from
+ bytes_from_utf8 is an allocated pointer that we must free. */
+ Safefree(key_p);
+ }
+
+ he->refcounted_he_data[0] = flags;
+ he->refcounted_he_refcnt = 1;
+
+ return he;
+}
+
+/*
+=for apidoc refcounted_he_free
+
+Decrements the reference count of the passed in C<struct refcounted_he *>
+by one. If the reference count reaches zero the structure's memory is freed,
+and C<refcounted_he_free> iterates onto the parent node.
+
+=cut
+*/
+
+void
+Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) {
+ PERL_UNUSED_CONTEXT;
+
+ while (he) {
+ struct refcounted_he *copy;
+ U32 new_count;
+
+ HINTS_REFCNT_LOCK;
+ new_count = --he->refcounted_he_refcnt;
+ HINTS_REFCNT_UNLOCK;
+
+ if (new_count) {
+ return;
+ }
+
+#ifndef USE_ITHREADS
+ unshare_hek_or_pvn (he->refcounted_he_hek, 0, 0, 0);
+#endif
+ copy = he;
+ he = he->refcounted_he_next;
+ PerlMemShared_free(copy);
+ }
+}
+
+/*
=for apidoc hv_assert
Check that a hash is in an internally consistent state.
=cut
*/
+#ifdef DEBUGGING
+
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)) {
- /* 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
+
/*
* Local variables:
* c-indentation-style: bsd
https://perl5.git.perl.org / perl5.git / blobdiff