static const char S_strtab_error[]
= "Cannot modify shared string table in hv_%s";
-STATIC void
-S_more_he(pTHX)
-{
- dVAR;
- /* We could generate this at compile time via (another) auxiliary C
- program? */
- const size_t arena_size = Perl_malloc_good_size(PERL_ARENA_SIZE);
- HE* he = (HE*) Perl_get_arena(aTHX_ arena_size, HE_SVSLOT);
- HE * const heend = &he[arena_size / sizeof(HE) - 1];
-
- PL_body_roots[HE_SVSLOT] = he;
- while (he < heend) {
- HeNEXT(he) = (HE*)(he + 1);
- he++;
- }
- HeNEXT(he) = 0;
-}
-
#ifdef PURIFY
#define new_HE() (HE*)safemalloc(sizeof(HE))
void ** const root = &PL_body_roots[HE_SVSLOT];
if (!*root)
- S_more_he(aTHX);
+ Perl_more_bodies(aTHX_ HE_SVSLOT, sizeof(HE), PERL_ARENA_SIZE);
he = (HE*) *root;
assert(he);
*root = HeNEXT(he);
C<hash> must be a valid precomputed hash number for the given C<key>, or 0
if you want the function to compute it. IF C<lval> is set then the fetch
will be part of a store. Make sure the return value is non-null before
-accessing it. The return value when C<tb> is a tied hash is a pointer to a
+accessing it. The return value when C<hv> is a tied hash is a pointer to a
static location, so be sure to make a copy of the structure if you need to
store it somewhere.
}
}
- if (HvREHASH(hv)) {
- PERL_HASH_INTERNAL(hash, key, klen);
- /* We don't have a pointer to the hv, so we have to replicate the
- flag into every HEK, so that hv_iterkeysv can see it. */
- /* And yes, you do need this even though you are not "storing" because
- you can flip the flags below if doing an lval lookup. (And that
- was put in to give the semantics Andreas was expecting.) */
+ if (HvREHASH(hv) || (!hash && !(keysv && (SvIsCOW_shared_hash(keysv)))))
+ PERL_HASH_INTERNAL_(hash, key, klen, HvREHASH(hv));
+ else if (!hash)
+ hash = SvSHARED_HASH(keysv);
+
+ /* We don't have a pointer to the hv, so we have to replicate the
+ flag into every HEK, so that hv_iterkeysv can see it.
+ And yes, you do need this even though you are not "storing" because
+ you can flip the flags below if doing an lval lookup. (And that
+ was put in to give the semantics Andreas was expecting.) */
+ if (HvREHASH(hv))
flags |= HVhek_REHASH;
- } else if (!hash) {
- if (keysv && (SvIsCOW_shared_hash(keysv))) {
- hash = SvSHARED_HASH(keysv);
- } else {
- PERL_HASH(hash, key, klen);
- }
- }
masked_flags = (flags & HVhek_MASK);
much back at this point (in hv_store's code). */
break;
}
- /* LVAL fetch which actaully needs a store. */
+ /* LVAL fetch which actually needs a store. */
val = newSV(0);
HvPLACEHOLDERS(hv)--;
} else {
return NULL;
}
if (action & HV_FETCH_LVALUE) {
- val = newSV(0);
+ val = action & HV_FETCH_EMPTY_HE ? NULL : newSV(0);
if (SvMAGICAL(hv)) {
/* At this point the old hv_fetch code would call to hv_store,
which in turn might do some tied magic. So we need to make that
xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
if (!counter) { /* initial entry? */
} else if (xhv->xhv_keys > xhv->xhv_max) {
+ /* Use only the old HvUSEDKEYS(hv) > HvMAX(hv) condition to limit
+ bucket splits on a rehashed hash, as we're not going to
+ split it again, and if someone is lucky (evil) enough to
+ get all the keys in one list they could exhaust our memory
+ as we repeatedly double the number of buckets on every
+ entry. Linear search feels a less worse thing to do. */
hsplit(hv);
} else if(!HvREHASH(hv)) {
U32 n_links = 1;
n_links++;
if (n_links > HV_MAX_LENGTH_BEFORE_SPLIT) {
- /* Use only the old HvKEYS(hv) > HvMAX(hv) condition to limit
- bucket splits on a rehashed hash, as we're not going to
- split it again, and if someone is lucky (evil) enough to
- get all the keys in one list they could exhaust our memory
- as we repeatedly double the number of buckets on every
- entry. Linear search feels a less worse thing to do. */
hsplit(hv);
}
}
/*
=for apidoc hv_delete
-Deletes a key/value pair in the hash. The value SV is removed from the
-hash and returned to the caller. The C<klen> is the length of the key.
-The C<flags> value will normally be zero; if set to G_DISCARD then NULL
-will be returned.
+Deletes a key/value pair in the hash. The value's SV is removed from the
+hash, made mortal, and returned to the caller. The C<klen> is the length of
+the key. The C<flags> value will normally be zero; if set to G_DISCARD then
+NULL will be returned. NULL will also be returned if the key is not found.
=for apidoc hv_delete_ent
-Deletes a key/value pair in the hash. The value SV is removed from the
-hash and returned to the caller. The C<flags> value will normally be zero;
-if set to G_DISCARD then NULL will be returned. C<hash> can be a valid
-precomputed hash value, or 0 to ask for it to be computed.
+Deletes a key/value pair in the hash. The value SV is removed from the hash,
+made mortal, and returned to the caller. The C<flags> value will normally be
+zero; if set to G_DISCARD then NULL will be returned. NULL will also be
+returned if the key is not found. C<hash> can be a valid precomputed hash
+value, or 0 to ask for it to be computed.
=cut
*/
register XPVHV* xhv;
register HE *entry;
register HE **oentry;
- HE *const *first_entry;
bool is_utf8 = (k_flags & HVhek_UTF8) ? TRUE : FALSE;
int masked_flags;
HvHASKFLAGS_on(MUTABLE_SV(hv));
}
- if (HvREHASH(hv)) {
- PERL_HASH_INTERNAL(hash, key, klen);
- } else if (!hash) {
- if (keysv && (SvIsCOW_shared_hash(keysv))) {
- hash = SvSHARED_HASH(keysv);
- } else {
- PERL_HASH(hash, key, klen);
- }
- }
+ if (HvREHASH(hv) || (!hash && !(keysv && (SvIsCOW_shared_hash(keysv)))))
+ PERL_HASH_INTERNAL_(hash, key, klen, HvREHASH(hv));
+ else if (!hash)
+ hash = SvSHARED_HASH(keysv);
masked_flags = (k_flags & HVhek_MASK);
- first_entry = oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)];
+ oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)];
entry = *oentry;
for (; entry; oentry = &HeNEXT(entry), entry = *oentry) {
SV *sv;
+ U8 mro_changes = 0; /* 1 = isa; 2 = package moved */
+ GV *gv = NULL;
+ HV *stash = NULL;
+
if (HeHASH(entry) != hash) /* strings can't be equal */
continue;
if (HeKLEN(entry) != (I32)klen)
if (k_flags & HVhek_FREEKEY)
Safefree(key);
+ /* If this is a stash and the key ends with ::, then someone is
+ * deleting a package.
+ */
+ if (HeVAL(entry) && HvENAME_get(hv)) {
+ gv = (GV *)HeVAL(entry);
+ if (keysv) key = SvPV(keysv, klen);
+ if ((
+ (klen > 1 && key[klen-2] == ':' && key[klen-1] == ':')
+ ||
+ (klen == 1 && key[0] == ':')
+ )
+ && (klen != 6 || hv!=PL_defstash || memNE(key,"main::",6))
+ && SvTYPE(gv) == SVt_PVGV && (stash = GvHV((GV *)gv))
+ && HvENAME_get(stash)) {
+ /* A previous version of this code checked that the
+ * GV was still in the symbol table by fetching the
+ * GV with its name. That is not necessary (and
+ * sometimes incorrect), as HvENAME cannot be set
+ * on hv if it is not in the symtab. */
+ mro_changes = 2;
+ /* Hang on to it for a bit. */
+ SvREFCNT_inc_simple_void_NN(
+ sv_2mortal((SV *)gv)
+ );
+ }
+ else if (klen == 3 && strnEQ(key, "ISA", 3))
+ mro_changes = 1;
+ }
+
if (d_flags & G_DISCARD)
sv = NULL;
else {
if (xhv->xhv_keys == 0)
HvHASKFLAGS_off(hv);
}
+
+ if (mro_changes == 1) mro_isa_changed_in(hv);
+ else if (mro_changes == 2)
+ mro_package_moved(NULL, stash, gv, 1);
+
return sv;
}
if (SvREADONLY(hv)) {
if (SvOOK(hv)) {
Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
}
- if (oldsize >= 64) {
- offer_nice_chunk(HvARRAY(hv),
- PERL_HV_ARRAY_ALLOC_BYTES(oldsize)
- + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0));
- }
- else
- Safefree(HvARRAY(hv));
+ Safefree(HvARRAY(hv));
#endif
PL_nomemok = FALSE;
if (SvOOK(hv)) {
Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
}
- if (oldsize >= 64) {
- offer_nice_chunk(HvARRAY(hv),
- PERL_HV_ARRAY_ALLOC_BYTES(oldsize)
- + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0));
- }
- else
- Safefree(HvARRAY(hv));
+ Safefree(HvARRAY(hv));
#endif
PL_nomemok = FALSE;
Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
return hv;
}
-/* A rather specialised version of newHVhv for copying %^H, ensuring all the
- magic stays on it. */
+/*
+=for apidoc Am|HV *|hv_copy_hints_hv|HV *ohv
+
+A specialised version of L</newHVhv> for copying C<%^H>. I<ohv> must be
+a pointer to a hash (which may have C<%^H> magic, but should be generally
+non-magical), or C<NULL> (interpreted as an empty hash). The content
+of I<ohv> is copied to a new hash, which has the C<%^H>-specific magic
+added to it. A pointer to the new hash is returned.
+
+=cut
+*/
+
HV *
Perl_hv_copy_hints_hv(pTHX_ HV *const ohv)
{
if (!entry)
return;
val = HeVAL(entry);
- if (val && isGV(val) && isGV_with_GP(val) && GvCVu(val) && HvNAME_get(hv))
+ if (val && isGV(val) && isGV_with_GP(val) && GvCVu(val) && HvENAME(hv))
mro_method_changed_in(hv); /* deletion of method from stash */
- SvREFCNT_dec(val);
if (HeKLEN(entry) == HEf_SVKEY) {
SvREFCNT_dec(HeKEY_sv(entry));
Safefree(HeKEY_hek(entry));
else
Safefree(HeKEY_hek(entry));
del_HE(entry);
+ SvREFCNT_dec(val);
}
}
}
}
- goto reset;
}
+ else {
+ hfreeentries(hv);
+ HvPLACEHOLDERS_set(hv, 0);
- hfreeentries(hv);
- HvPLACEHOLDERS_set(hv, 0);
- if (HvARRAY(hv))
- Zero(HvARRAY(hv), xhv->xhv_max+1 /* HvMAX(hv)+1 */, HE*);
-
- if (SvRMAGICAL(hv))
- mg_clear(MUTABLE_SV(hv));
+ if (SvRMAGICAL(hv))
+ mg_clear(MUTABLE_SV(hv));
- HvHASKFLAGS_off(hv);
- HvREHASH_off(hv);
- reset:
+ HvHASKFLAGS_off(hv);
+ HvREHASH_off(hv);
+ }
if (SvOOK(hv)) {
- if(HvNAME_get(hv))
+ if(HvENAME_get(hv))
mro_isa_changed_in(hv);
HvEITER_set(hv, NULL);
}
i = HvMAX(hv);
do {
/* Loop down the linked list heads */
- bool first = TRUE;
HE **oentry = &(HvARRAY(hv))[i];
HE *entry;
if (--items == 0) {
/* Finished. */
HvTOTALKEYS(hv) -= (IV)HvPLACEHOLDERS_get(hv);
- if (HvKEYS(hv) == 0)
+ if (HvUSEDKEYS(hv) == 0)
HvHASKFLAGS_off(hv);
HvPLACEHOLDERS_set(hv, 0);
return;
}
} else {
oentry = &HeNEXT(entry);
- first = FALSE;
}
}
} while (--i >= 0);
STATIC void
S_hfreeentries(pTHX_ HV *hv)
{
- /* This is the array that we're going to restore */
- HE **const orig_array = HvARRAY(hv);
- HEK *name;
- int attempts = 100;
+ STRLEN i = 0;
+ const bool mpm = PL_phase != PERL_PHASE_DESTRUCT && HvENAME(hv);
PERL_ARGS_ASSERT_HFREEENTRIES;
- if (!orig_array)
+ if (!HvARRAY(hv))
return;
- if (SvOOK(hv)) {
- /* If the hash is actually a symbol table with a name, look after the
- name. */
- struct xpvhv_aux *iter = HvAUX(hv);
-
- name = iter->xhv_name;
- iter->xhv_name = NULL;
- } else {
- name = NULL;
- }
-
- /* orig_array remains unchanged throughout the loop. If after freeing all
- the entries it turns out that one of the little blighters has triggered
- an action that has caused HvARRAY to be re-allocated, then we set
- array to the new HvARRAY, and try again. */
+ /* keep looping until all keys are removed. This may take multiple
+ * passes through the array, since destructors may add things back. */
- while (1) {
- /* This is the one we're going to try to empty. First time round
- it's the original array. (Hopefully there will only be 1 time
- round) */
- HE ** const array = HvARRAY(hv);
- I32 i = HvMAX(hv);
-
- /* Because we have taken xhv_name out, the only allocated pointer
- in the aux structure that might exist is the backreference array.
- */
-
- if (SvOOK(hv)) {
- HE *entry;
- struct mro_meta *meta;
- struct xpvhv_aux *iter = HvAUX(hv);
- /* weak references: if called from sv_clear(), the backrefs
- * should already have been killed; if there are any left, its
- * because we're doing hv_clear() or hv_undef(), and the HV
- * will continue to live.
- * Because while freeing the entries we fake up a NULL HvARRAY
- * (and hence HvAUX), we need to store the backref array
- * somewhere else; but it still needs to be visible in case
- * any the things we free happen to call sv_del_backref().
- * We do this by storing it in magic instead.
- * If, during the entry freeing, a destructor happens to add
- * a new weak backref, then sv_add_backref will look in both
- * places (magic in HvAUX) for the AV, but will create a new
- * AV in HvAUX if it can't find one. So at the end of the
- * iteration we have to allow for this. */
-
- if (iter->xhv_backreferences) {
- if (SvTYPE(iter->xhv_backreferences) == SVt_PVAV) {
- /* The sv_magic will increase the reference count of the AV,
- so we need to drop it first. */
- SvREFCNT_dec(iter->xhv_backreferences);
- if (AvFILLp(iter->xhv_backreferences) == -1) {
- /* Turns out that the array is empty. Just free it. */
- SvREFCNT_dec(iter->xhv_backreferences);
-
- } else {
- sv_magic(MUTABLE_SV(hv),
- MUTABLE_SV(iter->xhv_backreferences),
- PERL_MAGIC_backref, NULL, 0);
- }
- }
- else {
- MAGIC *mg;
- sv_magic(MUTABLE_SV(hv), NULL, PERL_MAGIC_backref, NULL, 0);
- mg = mg_find(MUTABLE_SV(hv), PERL_MAGIC_backref);
- mg->mg_obj = (SV*)iter->xhv_backreferences;
- }
- iter->xhv_backreferences = NULL;
- }
+ while (((XPVHV*)SvANY(hv))->xhv_keys) {
+ struct xpvhv_aux *iter;
+ HE *entry;
+ HE ** array;
- entry = iter->xhv_eiter; /* HvEITER(hv) */
+ if (SvOOK(hv) && ((iter = HvAUX(hv)))
+ && ((entry = iter->xhv_eiter)) )
+ {
+ /* the iterator may get resurrected after each
+ * destructor call, so check each time */
if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
HvLAZYDEL_off(hv);
hv_free_ent(hv, entry);
+ /* warning: at this point HvARRAY may have been
+ * re-allocated, HvMAX changed etc */
}
iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
-
- if((meta = iter->xhv_mro_meta)) {
- if (meta->mro_linear_all) {
- SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_all));
- meta->mro_linear_all = NULL;
- /* This is just acting as a shortcut pointer. */
- meta->mro_linear_current = NULL;
- } else if (meta->mro_linear_current) {
- /* Only the current MRO is stored, so this owns the data.
- */
- SvREFCNT_dec(meta->mro_linear_current);
- meta->mro_linear_current = NULL;
- }
- if(meta->mro_nextmethod) SvREFCNT_dec(meta->mro_nextmethod);
- SvREFCNT_dec(meta->isa);
- Safefree(meta);
- iter->xhv_mro_meta = NULL;
- }
-
- /* There are now no allocated pointers in the aux structure. */
-
- SvFLAGS(hv) &= ~SVf_OOK; /* Goodbye, aux structure. */
- /* What aux structure? */
}
- /* make everyone else think the array is empty, so that the destructors
- * called for freed entries can't recursively mess with us */
- HvARRAY(hv) = NULL;
- ((XPVHV*) SvANY(hv))->xhv_keys = 0;
-
-
- do {
- /* Loop down the linked list heads */
- HE *entry = array[i];
-
- while (entry) {
- register HE * const oentry = entry;
- entry = HeNEXT(entry);
- hv_free_ent(hv, oentry);
- }
- } while (--i >= 0);
-
- /* As there are no allocated pointers in the aux structure, it's now
- safe to free the array we just cleaned up, if it's not the one we're
- going to put back. */
- if (array != orig_array) {
- Safefree(array);
- }
-
- if (!HvARRAY(hv)) {
- /* Good. No-one added anything this time round. */
- break;
- }
-
- if (SvOOK(hv)) {
- /* Someone attempted to iterate or set the hash name while we had
- the array set to 0. We'll catch backferences on the next time
- round the while loop. */
- assert(HvARRAY(hv));
-
- if (HvAUX(hv)->xhv_name) {
- unshare_hek_or_pvn(HvAUX(hv)->xhv_name, 0, 0, 0);
+ array = HvARRAY(hv);
+ entry = array[i];
+ if (entry) {
+ /* Detach and free this entry. Note that destructors may be
+ * called which will manipulate this hash, so make sure
+ * its internal structure remains consistent throughout */
+ array[i] = HeNEXT(entry);
+ ((XPVHV*) SvANY(hv))->xhv_keys--;
+
+ if ( mpm && HeVAL(entry) && isGV(HeVAL(entry))
+ && GvHV(HeVAL(entry)) && HvENAME(GvHV(HeVAL(entry)))
+ ) {
+ STRLEN klen;
+ const char * const key = HePV(entry,klen);
+ if ((klen > 1 && key[klen-1]==':' && key[klen-2]==':')
+ || (klen == 1 && key[0] == ':')) {
+ mro_package_moved(
+ NULL, GvHV(HeVAL(entry)),
+ (GV *)HeVAL(entry), 0
+ );
+ }
}
+ hv_free_ent(hv, entry);
+ /* warning: at this point HvARRAY may have been
+ * re-allocated, HvMAX changed etc */
+ continue;
}
-
- if (--attempts == 0) {
- Perl_die(aTHX_ "panic: hfreeentries failed to free hash - something is repeatedly re-creating entries");
- }
- }
-
- HvARRAY(hv) = orig_array;
-
- /* If the hash was actually a symbol table, put the name back. */
- if (name) {
- /* We have restored the original array. If name is non-NULL, then
- the original array had an aux structure at the end. So this is
- valid: */
- SvFLAGS(hv) |= SVf_OOK;
- HvAUX(hv)->xhv_name = name;
- }
+ if (i++ >= HvMAX(hv))
+ i = 0;
+ } /* while */
}
/*
*/
void
-Perl_hv_undef(pTHX_ HV *hv)
+Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags)
{
dVAR;
register XPVHV* xhv;
DEBUG_A(Perl_hv_assert(aTHX_ hv));
xhv = (XPVHV*)SvANY(hv);
- if ((name = HvNAME_get(hv)) && !PL_dirty)
- mro_isa_changed_in(hv);
-
- hfreeentries(hv);
- if (name) {
+ /* The name must be deleted before the call to hfreeeeentries so that
+ CVs are anonymised properly. But the effective name must be pre-
+ served until after that call (and only deleted afterwards if the
+ call originated from sv_clear). For stashes with one name that is
+ both the canonical name and the effective name, hv_name_set has to
+ allocate an array for storing the effective name. We can skip that
+ during global destruction, as it does not matter where the CVs point
+ if they will be freed anyway. */
+ if (PL_phase != PERL_PHASE_DESTRUCT && (name = HvNAME(hv))) {
if (PL_stashcache)
(void)hv_delete(PL_stashcache, name, HvNAMELEN_get(hv), G_DISCARD);
hv_name_set(hv, NULL, 0, 0);
}
- SvFLAGS(hv) &= ~SVf_OOK;
- Safefree(HvARRAY(hv));
- xhv->xhv_max = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
- HvARRAY(hv) = 0;
+ hfreeentries(hv);
+ if (SvOOK(hv)) {
+ struct xpvhv_aux * const aux = HvAUX(hv);
+ struct mro_meta *meta;
+
+ if ((name = HvENAME_get(hv))) {
+ if (PL_phase != PERL_PHASE_DESTRUCT)
+ mro_isa_changed_in(hv);
+ if (PL_stashcache)
+ (void)hv_delete(
+ PL_stashcache, name, HvENAMELEN_get(hv), G_DISCARD
+ );
+ }
+
+ /* If this call originated from sv_clear, then we must check for
+ * effective names that need freeing, as well as the usual name. */
+ name = HvNAME(hv);
+ if (flags & HV_NAME_SETALL ? !!aux->xhv_name_u.xhvnameu_name : !!name) {
+ if (name && PL_stashcache)
+ (void)hv_delete(PL_stashcache, name, HvNAMELEN_get(hv), G_DISCARD);
+ hv_name_set(hv, NULL, 0, flags);
+ }
+ if((meta = aux->xhv_mro_meta)) {
+ if (meta->mro_linear_all) {
+ SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_all));
+ meta->mro_linear_all = NULL;
+ /* This is just acting as a shortcut pointer. */
+ meta->mro_linear_current = NULL;
+ } else if (meta->mro_linear_current) {
+ /* Only the current MRO is stored, so this owns the data.
+ */
+ SvREFCNT_dec(meta->mro_linear_current);
+ meta->mro_linear_current = NULL;
+ }
+ if(meta->mro_nextmethod) SvREFCNT_dec(meta->mro_nextmethod);
+ SvREFCNT_dec(meta->isa);
+ Safefree(meta);
+ aux->xhv_mro_meta = NULL;
+ }
+ if (!aux->xhv_name_u.xhvnameu_name && ! aux->xhv_backreferences)
+ SvFLAGS(hv) &= ~SVf_OOK;
+ }
+ if (!SvOOK(hv)) {
+ Safefree(HvARRAY(hv));
+ xhv->xhv_max = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
+ HvARRAY(hv) = 0;
+ }
HvPLACEHOLDERS_set(hv, 0);
if (SvRMAGICAL(hv))
iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
- iter->xhv_name = 0;
+ iter->xhv_name_u.xhvnameu_name = 0;
+ iter->xhv_name_count = 0;
iter->xhv_backreferences = 0;
iter->xhv_mro_meta = NULL;
return iter;
=for apidoc hv_iterinit
Prepares a starting point to traverse a hash table. Returns the number of
-keys in the hash (i.e. the same as C<HvKEYS(tb)>). The return value is
+keys in the hash (i.e. the same as C<HvUSEDKEYS(hv)>). The return value is
currently only meaningful for hashes without tie magic.
NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
hash buckets that happen to be in use. If you still need that esoteric
-value, you can get it through the macro C<HvFILL(tb)>.
+value, you can get it through the macro C<HvFILL(hv)>.
=cut
dVAR;
struct xpvhv_aux *iter;
U32 hash;
+ HEK **spot;
PERL_ARGS_ASSERT_HV_NAME_SET;
PERL_UNUSED_ARG(flags);
if (SvOOK(hv)) {
iter = HvAUX(hv);
- if (iter->xhv_name) {
- unshare_hek_or_pvn(iter->xhv_name, 0, 0, 0);
+ if (iter->xhv_name_u.xhvnameu_name) {
+ if(iter->xhv_name_count) {
+ if(flags & HV_NAME_SETALL) {
+ HEK ** const name = HvAUX(hv)->xhv_name_u.xhvnameu_names;
+ HEK **hekp = name + (
+ iter->xhv_name_count < 0
+ ? -iter->xhv_name_count
+ : iter->xhv_name_count
+ );
+ while(hekp-- > name+1)
+ unshare_hek_or_pvn(*hekp, 0, 0, 0);
+ /* The first elem may be null. */
+ if(*name) unshare_hek_or_pvn(*name, 0, 0, 0);
+ Safefree(name);
+ spot = &iter->xhv_name_u.xhvnameu_name;
+ iter->xhv_name_count = 0;
+ }
+ else {
+ if(iter->xhv_name_count > 0) {
+ /* shift some things over */
+ Renew(
+ iter->xhv_name_u.xhvnameu_names, iter->xhv_name_count + 1, HEK *
+ );
+ spot = iter->xhv_name_u.xhvnameu_names;
+ spot[iter->xhv_name_count] = spot[1];
+ spot[1] = spot[0];
+ iter->xhv_name_count = -(iter->xhv_name_count + 1);
+ }
+ else if(*(spot = iter->xhv_name_u.xhvnameu_names)) {
+ unshare_hek_or_pvn(*spot, 0, 0, 0);
+ }
+ }
+ }
+ else if (flags & HV_NAME_SETALL) {
+ unshare_hek_or_pvn(iter->xhv_name_u.xhvnameu_name, 0, 0, 0);
+ spot = &iter->xhv_name_u.xhvnameu_name;
+ }
+ else {
+ HEK * const existing_name = iter->xhv_name_u.xhvnameu_name;
+ Newx(iter->xhv_name_u.xhvnameu_names, 2, HEK *);
+ iter->xhv_name_count = -2;
+ spot = iter->xhv_name_u.xhvnameu_names;
+ spot[1] = existing_name;
+ }
}
+ else { spot = &iter->xhv_name_u.xhvnameu_name; iter->xhv_name_count = 0; }
} else {
if (name == 0)
return;
iter = hv_auxinit(hv);
+ spot = &iter->xhv_name_u.xhvnameu_name;
}
PERL_HASH(hash, name, len);
- iter->xhv_name = name ? share_hek(name, len, hash) : NULL;
+ *spot = name ? share_hek(name, len, hash) : NULL;
+}
+
+/*
+=for apidoc hv_ename_add
+
+Adds a name to a stash's internal list of effective names. See
+C<hv_ename_delete>.
+
+This is called when a stash is assigned to a new location in the symbol
+table.
+
+=cut
+*/
+
+void
+Perl_hv_ename_add(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
+{
+ dVAR;
+ struct xpvhv_aux *aux = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
+ U32 hash;
+
+ PERL_ARGS_ASSERT_HV_ENAME_ADD;
+ PERL_UNUSED_ARG(flags);
+
+ if (len > I32_MAX)
+ Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
+
+ PERL_HASH(hash, name, len);
+
+ if (aux->xhv_name_count) {
+ HEK ** const xhv_name = aux->xhv_name_u.xhvnameu_names;
+ I32 count = aux->xhv_name_count;
+ HEK **hekp = xhv_name + (count < 0 ? -count : count);
+ while (hekp-- > xhv_name)
+ if (
+ HEK_LEN(*hekp) == (I32)len && memEQ(HEK_KEY(*hekp), name, len)
+ ) {
+ if (hekp == xhv_name && count < 0)
+ aux->xhv_name_count = -count;
+ return;
+ }
+ if (count < 0) aux->xhv_name_count--, count = -count;
+ else aux->xhv_name_count++;
+ Renew(aux->xhv_name_u.xhvnameu_names, count + 1, HEK *);
+ (aux->xhv_name_u.xhvnameu_names)[count] = share_hek(name, len, hash);
+ }
+ else {
+ HEK *existing_name = aux->xhv_name_u.xhvnameu_name;
+ if (
+ existing_name && HEK_LEN(existing_name) == (I32)len
+ && memEQ(HEK_KEY(existing_name), name, len)
+ ) return;
+ Newx(aux->xhv_name_u.xhvnameu_names, 2, HEK *);
+ aux->xhv_name_count = existing_name ? 2 : -2;
+ *aux->xhv_name_u.xhvnameu_names = existing_name;
+ (aux->xhv_name_u.xhvnameu_names)[1] = share_hek(name, len, hash);
+ }
+}
+
+/*
+=for apidoc hv_ename_delete
+
+Removes a name from a stash's internal list of effective names. If this is
+the name returned by C<HvENAME>, then another name in the list will take
+its place (C<HvENAME> will use it).
+
+This is called when a stash is deleted from the symbol table.
+
+=cut
+*/
+
+void
+Perl_hv_ename_delete(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
+{
+ dVAR;
+ struct xpvhv_aux *aux;
+
+ PERL_ARGS_ASSERT_HV_ENAME_DELETE;
+ PERL_UNUSED_ARG(flags);
+
+ 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_u.xhvnameu_name) return;
+
+ if (aux->xhv_name_count) {
+ HEK ** const namep = aux->xhv_name_u.xhvnameu_names;
+ I32 const count = aux->xhv_name_count;
+ HEK **victim = namep + (count < 0 ? -count : count);
+ while (victim-- > namep + 1)
+ if (
+ HEK_LEN(*victim) == (I32)len
+ && memEQ(HEK_KEY(*victim), name, len)
+ ) {
+ unshare_hek_or_pvn(*victim, 0, 0, 0);
+ if (count < 0) ++aux->xhv_name_count;
+ else --aux->xhv_name_count;
+ if (
+ (aux->xhv_name_count == 1 || aux->xhv_name_count == -1)
+ && !*namep
+ ) { /* if there are none left */
+ Safefree(namep);
+ aux->xhv_name_u.xhvnameu_names = NULL;
+ aux->xhv_name_count = 0;
+ }
+ else {
+ /* Move the last one back to fill the empty slot. It
+ does not matter what order they are in. */
+ *victim = *(namep + (count < 0 ? -count : count) - 1);
+ }
+ return;
+ }
+ if (
+ count > 0 && HEK_LEN(*namep) == (I32)len
+ && memEQ(HEK_KEY(*namep),name,len)
+ ) {
+ aux->xhv_name_count = -count;
+ }
+ }
+ else if(
+ HEK_LEN(aux->xhv_name_u.xhvnameu_name) == (I32)len
+ && memEQ(HEK_KEY(aux->xhv_name_u.xhvnameu_name), name, len)
+ ) {
+ HEK * const namehek = aux->xhv_name_u.xhvnameu_name;
+ Newx(aux->xhv_name_u.xhvnameu_names, 1, HEK *);
+ *aux->xhv_name_u.xhvnameu_names = namehek;
+ aux->xhv_name_count = -1;
+ }
}
AV **
register XPVHV* xhv;
HE *entry;
register HE **oentry;
- HE **first;
bool is_utf8 = FALSE;
int k_flags = 0;
const char * const save = str;
} */
xhv = (XPVHV*)SvANY(PL_strtab);
/* assert(xhv_array != 0) */
- first = oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)];
+ oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)];
if (he) {
const HE *const he_he = &(he->shared_he_he);
for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
if (!next) { /* initial entry? */
- } else if (xhv->xhv_keys > xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) {
+ } else if (xhv->xhv_keys > xhv->xhv_max /* HvUSEDKEYS(hv) > HvMAX(hv) */) {
hsplit(PL_strtab);
}
}
SvUTF8_on(value);
break;
default:
- Perl_croak(aTHX_ "panic: refcounted_he_value bad flags %x",
- he->refcounted_he_data[0]);
+ Perl_croak(aTHX_ "panic: refcounted_he_value bad flags %"UVxf,
+ (UV)he->refcounted_he_data[0]);
}
return value;
}
/*
-=for apidoc refcounted_he_chain_2hv
+=for apidoc m|HV *|refcounted_he_chain_2hv|const struct refcounted_he *c|U32 flags
-Generates and returns a C<HV *> by walking up the tree starting at the passed
-in C<struct refcounted_he *>.
+Generates and returns a C<HV *> representing the content of a
+C<refcounted_he> chain.
+I<flags> is currently unused and must be zero.
=cut
*/
HV *
-Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain)
+Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain, U32 flags)
{
dVAR;
- HV *hv = newHV();
- U32 placeholders = 0;
+ HV *hv;
+ U32 placeholders, max;
+
+ if (flags)
+ Perl_croak(aTHX_ "panic: refcounted_he_chain_2hv bad flags %"UVxf,
+ (UV)flags);
+
/* 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);
-
+ hv = newHV();
+ max = HvMAX(hv);
if (!HvARRAY(hv)) {
char *array;
Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(max + 1), char);
HvARRAY(hv) = (HE**)array;
}
+ placeholders = 0;
while (chain) {
#ifdef USE_ITHREADS
U32 hash = chain->refcounted_he_hash;
return hv;
}
+/*
+=for apidoc m|SV *|refcounted_he_fetch_pvn|const struct refcounted_he *chain|const char *keypv|STRLEN keylen|U32 hash|U32 flags
+
+Search along a C<refcounted_he> chain for an entry with the key specified
+by I<keypv> and I<keylen>. If I<flags> has the C<REFCOUNTED_HE_KEY_UTF8>
+bit set, the key octets are interpreted as UTF-8, otherwise they
+are interpreted as Latin-1. I<hash> is a precomputed hash of the key
+string, or zero if it has not been precomputed. Returns a mortal scalar
+representing the value associated with the key, or C<&PL_sv_placeholder>
+if there is no value associated with the key.
+
+=cut
+*/
+
SV *
-Perl_refcounted_he_fetch(pTHX_ const struct refcounted_he *chain, SV *keysv,
- const char *key, STRLEN klen, int flags, U32 hash)
+Perl_refcounted_he_fetch_pvn(pTHX_ const struct refcounted_he *chain,
+ const char *keypv, STRLEN keylen, U32 hash, U32 flags)
{
dVAR;
- /* Just to be awkward, if you're using this interface the UTF-8-or-not-ness
- of your key has to exactly match that which is stored. */
- SV *value = &PL_sv_placeholder;
-
- if (chain) {
- /* No point in doing any of this if there's nothing to find. */
- bool is_utf8;
+ U8 utf8_flag;
+ PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PVN;
- if (keysv) {
- if (flags & HVhek_FREEKEY)
- Safefree(key);
- key = SvPV_const(keysv, klen);
- flags = 0;
- is_utf8 = (SvUTF8(keysv) != 0);
- } else {
- is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE);
+ if (flags & ~REFCOUNTED_HE_KEY_UTF8)
+ Perl_croak(aTHX_ "panic: refcounted_he_fetch_pvn bad flags %"UVxf,
+ (UV)flags);
+ if (!chain)
+ return &PL_sv_placeholder;
+ if (flags & REFCOUNTED_HE_KEY_UTF8) {
+ /* For searching purposes, canonicalise to Latin-1 where possible. */
+ const char *keyend = keypv + keylen, *p;
+ STRLEN nonascii_count = 0;
+ for (p = keypv; p != keyend; p++) {
+ U8 c = (U8)*p;
+ if (c & 0x80) {
+ if (!((c & 0xfe) == 0xc2 && ++p != keyend &&
+ (((U8)*p) & 0xc0) == 0x80))
+ goto canonicalised_key;
+ nonascii_count++;
+ }
}
-
- if (!hash) {
- if (keysv && (SvIsCOW_shared_hash(keysv))) {
- hash = SvSHARED_HASH(keysv);
- } else {
- PERL_HASH(hash, key, klen);
+ if (nonascii_count) {
+ char *q;
+ const char *p = keypv, *keyend = keypv + keylen;
+ keylen -= nonascii_count;
+ Newx(q, keylen, char);
+ SAVEFREEPV(q);
+ keypv = q;
+ for (; p != keyend; p++, q++) {
+ U8 c = (U8)*p;
+ *q = (char)
+ ((c & 0x80) ? ((c & 0x03) << 6) | (((U8)*++p) & 0x3f) : c);
}
}
+ flags &= ~REFCOUNTED_HE_KEY_UTF8;
+ canonicalised_key: ;
+ }
+ utf8_flag = (flags & REFCOUNTED_HE_KEY_UTF8) ? HVhek_UTF8 : 0;
+ if (!hash)
+ PERL_HASH(hash, keypv, keylen);
- for (; chain; chain = chain->refcounted_he_next) {
+ for (; chain; chain = chain->refcounted_he_next) {
+ if (
#ifdef USE_ITHREADS
- if (hash != chain->refcounted_he_hash)
- continue;
- if (klen != chain->refcounted_he_keylen)
- continue;
- if (memNE(REF_HE_KEY(chain),key,klen))
- continue;
- if (!!is_utf8 != !!(chain->refcounted_he_data[0] & HVhek_UTF8))
- continue;
+ hash == chain->refcounted_he_hash &&
+ keylen == chain->refcounted_he_keylen &&
+ memEQ(REF_HE_KEY(chain), keypv, keylen) &&
+ utf8_flag == (chain->refcounted_he_data[0] & HVhek_UTF8)
#else
- if (hash != HEK_HASH(chain->refcounted_he_hek))
- continue;
- if (klen != (STRLEN)HEK_LEN(chain->refcounted_he_hek))
- continue;
- if (memNE(HEK_KEY(chain->refcounted_he_hek),key,klen))
- continue;
- if (!!is_utf8 != !!HEK_UTF8(chain->refcounted_he_hek))
- continue;
+ hash == HEK_HASH(chain->refcounted_he_hek) &&
+ keylen == (STRLEN)HEK_LEN(chain->refcounted_he_hek) &&
+ memEQ(HEK_KEY(chain->refcounted_he_hek), keypv, keylen) &&
+ utf8_flag == (HEK_FLAGS(chain->refcounted_he_hek) & HVhek_UTF8)
#endif
-
- value = sv_2mortal(refcounted_he_value(chain));
- break;
- }
+ )
+ return sv_2mortal(refcounted_he_value(chain));
}
+ return &PL_sv_placeholder;
+}
- if (flags & HVhek_FREEKEY)
- Safefree(key);
+/*
+=for apidoc m|SV *|refcounted_he_fetch_pv|const struct refcounted_he *chain|const char *key|U32 hash|U32 flags
- return value;
+Like L</refcounted_he_fetch_pvn>, but takes a nul-terminated string
+instead of a string/length pair.
+
+=cut
+*/
+
+SV *
+Perl_refcounted_he_fetch_pv(pTHX_ const struct refcounted_he *chain,
+ const char *key, U32 hash, U32 flags)
+{
+ PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PV;
+ return refcounted_he_fetch_pvn(chain, key, strlen(key), hash, flags);
}
/*
-=for apidoc refcounted_he_new
+=for apidoc m|SV *|refcounted_he_fetch_sv|const struct refcounted_he *chain|SV *key|U32 hash|U32 flags
+
+Like L</refcounted_he_fetch_pvn>, but takes a Perl scalar instead of a
+string/length pair.
-Creates a new C<struct refcounted_he>. As S<key> is copied, and value is
-stored in a compact form, all references remain the property of the caller.
-The C<struct refcounted_he> is returned with a reference count of 1.
+=cut
+*/
+
+SV *
+Perl_refcounted_he_fetch_sv(pTHX_ const struct refcounted_he *chain,
+ SV *key, U32 hash, U32 flags)
+{
+ const char *keypv;
+ STRLEN keylen;
+ PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_SV;
+ if (flags & REFCOUNTED_HE_KEY_UTF8)
+ Perl_croak(aTHX_ "panic: refcounted_he_fetch_sv bad flags %"UVxf,
+ (UV)flags);
+ keypv = SvPV_const(key, keylen);
+ if (SvUTF8(key))
+ flags |= REFCOUNTED_HE_KEY_UTF8;
+ if (!hash && SvIsCOW_shared_hash(key))
+ hash = SvSHARED_HASH(key);
+ return refcounted_he_fetch_pvn(chain, keypv, keylen, hash, flags);
+}
+
+/*
+=for apidoc m|struct refcounted_he *|refcounted_he_new_pvn|struct refcounted_he *parent|const char *keypv|STRLEN keylen|U32 hash|SV *value|U32 flags
+
+Creates a new C<refcounted_he>. This consists of a single key/value
+pair and a reference to an existing C<refcounted_he> chain (which may
+be empty), and thus forms a longer chain. When using the longer chain,
+the new key/value pair takes precedence over any entry for the same key
+further along the chain.
+
+The new key is specified by I<keypv> and I<keylen>. If I<flags> has
+the C<REFCOUNTED_HE_KEY_UTF8> bit set, the key octets are interpreted
+as UTF-8, otherwise they are interpreted as Latin-1. I<hash> is
+a precomputed hash of the key string, or zero if it has not been
+precomputed.
+
+I<value> is the scalar value to store for this key. I<value> is copied
+by this function, which thus does not take ownership of any reference
+to it, and later changes to the scalar will not be reflected in the
+value visible in the C<refcounted_he>. Complex types of scalar will not
+be stored with referential integrity, but will be coerced to strings.
+I<value> may be either null or C<&PL_sv_placeholder> to indicate that no
+value is to be associated with the key; this, as with any non-null value,
+takes precedence over the existence of a value for the key further along
+the chain.
+
+I<parent> points to the rest of the C<refcounted_he> chain to be
+attached to the new C<refcounted_he>. This function takes ownership
+of one reference to I<parent>, and returns one reference to the new
+C<refcounted_he>.
=cut
*/
struct refcounted_he *
-Perl_refcounted_he_new(pTHX_ struct refcounted_he *const parent,
- SV *const key, SV *const value) {
+Perl_refcounted_he_new_pvn(pTHX_ struct refcounted_he *parent,
+ const char *keypv, STRLEN keylen, U32 hash, SV *value, U32 flags)
+{
dVAR;
- STRLEN key_len;
- const char *key_p = SvPV_const(key, key_len);
STRLEN value_len = 0;
const char *value_p = NULL;
+ bool is_pv;
char value_type;
- char flags;
- bool is_utf8 = SvUTF8(key) ? TRUE : FALSE;
+ char hekflags;
+ STRLEN key_offset = 1;
+ struct refcounted_he *he;
+ PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PVN;
- if (SvPOK(value)) {
+ if (!value || value == &PL_sv_placeholder) {
+ value_type = HVrhek_delete;
+ } else if (SvPOK(value)) {
value_type = HVrhek_PV;
} else if (SvIOK(value)) {
value_type = SvUOK((const SV *)value) ? HVrhek_UV : 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) {
+ is_pv = value_type == HVrhek_PV;
+ if (is_pv) {
/* Do it this way so that the SvUTF8() test is after the SvPV, in case
the value is overloaded, and doesn't yet have the UTF-8flag set. */
value_p = SvPV_const(value, value_len);
if (SvUTF8(value))
value_type = HVrhek_PV_UTF8;
+ key_offset = value_len + 2;
+ }
+ hekflags = value_type;
+
+ if (flags & REFCOUNTED_HE_KEY_UTF8) {
+ /* Canonicalise to Latin-1 where possible. */
+ const char *keyend = keypv + keylen, *p;
+ STRLEN nonascii_count = 0;
+ for (p = keypv; p != keyend; p++) {
+ U8 c = (U8)*p;
+ if (c & 0x80) {
+ if (!((c & 0xfe) == 0xc2 && ++p != keyend &&
+ (((U8)*p) & 0xc0) == 0x80))
+ goto canonicalised_key;
+ nonascii_count++;
+ }
+ }
+ if (nonascii_count) {
+ char *q;
+ const char *p = keypv, *keyend = keypv + keylen;
+ keylen -= nonascii_count;
+ Newx(q, keylen, char);
+ SAVEFREEPV(q);
+ keypv = q;
+ for (; p != keyend; p++, q++) {
+ U8 c = (U8)*p;
+ *q = (char)
+ ((c & 0x80) ? ((c & 0x03) << 6) | (((U8)*++p) & 0x3f) : c);
+ }
+ }
+ flags &= ~REFCOUNTED_HE_KEY_UTF8;
+ canonicalised_key: ;
}
- flags = value_type;
-
- 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;
- }
-
- return refcounted_he_new_common(parent, key_p, key_len, flags, value_type,
- ((value_type == HVrhek_PV
- || value_type == HVrhek_PV_UTF8) ?
- (void *)value_p : (void *)value),
- value_len);
-}
-
-static struct refcounted_he *
-S_refcounted_he_new_common(pTHX_ struct refcounted_he *const parent,
- const char *const key_p, const STRLEN key_len,
- const char flags, char value_type,
- const void *value, const STRLEN value_len) {
- dVAR;
- struct refcounted_he *he;
- U32 hash;
- const bool is_pv = value_type == HVrhek_PV || value_type == HVrhek_PV_UTF8;
- STRLEN key_offset = is_pv ? value_len + 2 : 1;
-
- PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_COMMON;
+ if (flags & REFCOUNTED_HE_KEY_UTF8)
+ hekflags |= HVhek_UTF8;
+ if (!hash)
+ PERL_HASH(hash, keypv, keylen);
#ifdef USE_ITHREADS
he = (struct refcounted_he*)
PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
- + key_len
+ + keylen
+ key_offset);
#else
he = (struct refcounted_he*)
he->refcounted_he_next = parent;
if (is_pv) {
- Copy((char *)value, he->refcounted_he_data + 1, value_len + 1, char);
+ Copy(value_p, he->refcounted_he_data + 1, value_len + 1, char);
he->refcounted_he_val.refcounted_he_u_len = value_len;
} else if (value_type == HVrhek_IV) {
- he->refcounted_he_val.refcounted_he_u_iv = SvIVX((const SV *)value);
+ he->refcounted_he_val.refcounted_he_u_iv = SvIVX(value);
} else if (value_type == HVrhek_UV) {
- he->refcounted_he_val.refcounted_he_u_uv = SvUVX((const SV *)value);
+ he->refcounted_he_val.refcounted_he_u_uv = SvUVX(value);
}
- 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);
+ he->refcounted_he_keylen = keylen;
+ Copy(keypv, he->refcounted_he_data + key_offset, keylen, char);
#else
- he->refcounted_he_hek = share_hek_flags(key_p, key_len, hash, flags);
+ he->refcounted_he_hek = share_hek_flags(keypv, keylen, hash, hekflags);
#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_data[0] = hekflags;
he->refcounted_he_refcnt = 1;
return he;
}
/*
-=for apidoc refcounted_he_free
+=for apidoc m|struct refcounted_he *|refcounted_he_new_pv|struct refcounted_he *parent|const char *key|U32 hash|SV *value|U32 flags
+
+Like L</refcounted_he_new_pvn>, but takes a nul-terminated string instead
+of a string/length pair.
+
+=cut
+*/
+
+struct refcounted_he *
+Perl_refcounted_he_new_pv(pTHX_ struct refcounted_he *parent,
+ const char *key, U32 hash, SV *value, U32 flags)
+{
+ PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PV;
+ return refcounted_he_new_pvn(parent, key, strlen(key), hash, value, flags);
+}
+
+/*
+=for apidoc m|struct refcounted_he *|refcounted_he_new_sv|struct refcounted_he *parent|SV *key|U32 hash|SV *value|U32 flags
-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.
+Like L</refcounted_he_new_pvn>, but takes a Perl scalar instead of a
+string/length pair.
+
+=cut
+*/
+
+struct refcounted_he *
+Perl_refcounted_he_new_sv(pTHX_ struct refcounted_he *parent,
+ SV *key, U32 hash, SV *value, U32 flags)
+{
+ const char *keypv;
+ STRLEN keylen;
+ PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_SV;
+ if (flags & REFCOUNTED_HE_KEY_UTF8)
+ Perl_croak(aTHX_ "panic: refcounted_he_new_sv bad flags %"UVxf,
+ (UV)flags);
+ keypv = SvPV_const(key, keylen);
+ if (SvUTF8(key))
+ flags |= REFCOUNTED_HE_KEY_UTF8;
+ if (!hash && SvIsCOW_shared_hash(key))
+ hash = SvSHARED_HASH(key);
+ return refcounted_he_new_pvn(parent, keypv, keylen, hash, value, flags);
+}
+
+/*
+=for apidoc m|void|refcounted_he_free|struct refcounted_he *he
+
+Decrements the reference count of a C<refcounted_he> by one. If the
+reference count reaches zero the structure's memory is freed, which
+(recursively) causes a reduction of its parent C<refcounted_he>'s
+reference count. It is safe to pass a null pointer to this function:
+no action occurs in this case.
=cut
*/
}
}
+/*
+=for apidoc m|struct refcounted_he *|refcounted_he_inc|struct refcounted_he *he
+
+Increment the reference count of a C<refcounted_he>. The pointer to the
+C<refcounted_he> is also returned. It is safe to pass a null pointer
+to this function: no action occurs and a null pointer is returned.
+
+=cut
+*/
+
+struct refcounted_he *
+Perl_refcounted_he_inc(pTHX_ struct refcounted_he *he)
+{
+ if (he) {
+ HINTS_REFCNT_LOCK;
+ he->refcounted_he_refcnt++;
+ HINTS_REFCNT_UNLOCK;
+ }
+ return he;
+}
+
/* pp_entereval is aware that labels are stored with a key ':' at the top of
the linked list. */
const char *
-Perl_fetch_cop_label(pTHX_ struct refcounted_he *const chain, STRLEN *len,
- U32 *flags) {
+Perl_fetch_cop_label(pTHX_ COP *const cop, STRLEN *len, U32 *flags) {
+ struct refcounted_he *const chain = cop->cop_hints_hash;
+
+ PERL_ARGS_ASSERT_FETCH_COP_LABEL;
+
if (!chain)
return NULL;
#ifdef USE_ITHREADS
return chain->refcounted_he_data + 1;
}
-/* As newSTATEOP currently gets passed plain char* labels, we will only provide
- that interface. Once it works out how to pass in length and UTF-8 ness, this
- function will need superseding. */
-struct refcounted_he *
-Perl_store_cop_label(pTHX_ struct refcounted_he *const chain, const char *label)
+void
+Perl_store_cop_label(pTHX_ COP *const cop, const char *label, STRLEN len,
+ U32 flags)
{
+ SV *labelsv;
PERL_ARGS_ASSERT_STORE_COP_LABEL;
- return refcounted_he_new_common(chain, ":", 1, HVrhek_PV, HVrhek_PV,
- label, strlen(label));
+ if (flags & ~(SVf_UTF8))
+ Perl_croak(aTHX_ "panic: store_cop_label illegal flag bits 0x%" UVxf,
+ (UV)flags);
+ labelsv = newSVpvn_flags(label, len, SVs_TEMP);
+ if (flags & SVf_UTF8)
+ SvUTF8_on(labelsv);
+ cop->cop_hints_hash
+ = refcounted_he_new_pvs(cop->cop_hints_hash, ":", labelsv, 0);
}
/*
https://perl5.git.perl.org / perl5.git / blobdiff