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);
char *k;
Newx(k, HEK_BASESIZE + sizeof(const SV *), char);
HeKEY_hek(ret) = (HEK*)k;
- HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e), param));
+ HeKEY_sv(ret) = sv_dup_inc(HeKEY_sv(e), param);
}
else if (shared) {
/* This is hek_dup inlined, which seems to be important for speed
else
HeKEY_hek(ret) = save_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e),
HeKFLAGS(e));
- HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e), param));
+ HeVAL(ret) = sv_dup_inc(HeVAL(e), param);
return ret;
}
#endif /* USE_ITHREADS */
/*
=for apidoc hv_store
-Stores an SV in a hash. The hash key is specified as C<key> and C<klen> is
-the length of the key. The C<hash> parameter is the precomputed hash
-value; if it is zero then Perl will compute it. The return value will be
+Stores an SV in a hash. The hash key is specified as C<key> and the
+absolute value of C<klen> is the length of the key. If C<klen> is
+negative the key is assumed to be in UTF-8-encoded Unicode. The
+C<hash> parameter is the precomputed hash value; if it is zero then
+Perl will compute it.
+
+The return value will be
NULL if the operation failed or if the value did not need to be actually
stored within the hash (as in the case of tied hashes). Otherwise it can
be dereferenced to get the original C<SV*>. Note that the caller is
=for apidoc hv_exists
Returns a boolean indicating whether the specified hash key exists. The
-C<klen> is the length of the key.
+absolute value of C<klen> is the length of the key. If C<klen> is
+negative the key is assumed to be in UTF-8-encoded Unicode.
=for apidoc hv_fetch
-Returns the SV which corresponds to the specified key in the hash. The
-C<klen> is the length of the key. If C<lval> is set then the fetch will be
-part of a store. Check that the return value is non-null before
-dereferencing it to an C<SV*>.
+Returns the SV which corresponds to the specified key in the hash.
+The absolute value of C<klen> is the length of the key. If C<klen> is
+negative the key is assumed to be in UTF-8-encoded Unicode. If
+C<lval> is set then the fetch will be part of a store. Check that the
+return value is non-null before dereferencing it to an C<SV*>.
See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
information on how to use this function on tied hashes.
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 (!hv)
return NULL;
- if (SvTYPE(hv) == SVTYPEMASK)
+ if (SvTYPE(hv) == (svtype)SVTYPEMASK)
return NULL;
assert(SvTYPE(hv) == SVt_PVHV);
}
}
- 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 > (IV)xhv->xhv_max) {
+ } 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 absolute
+value of C<klen> is the length of the key. If C<klen> is negative the
+key is assumed to be in UTF-8-encoded Unicode. 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)
Safefree(key);
return NULL;
}
- if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
+ if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))
+ && !SvIsCOW(HeVAL(entry))) {
hv_notallowed(k_flags, key, klen,
"Attempt to delete readonly key '%"SVf"' from"
" a restricted hash");
if (k_flags & HVhek_FREEKEY)
Safefree(key);
- if (d_flags & G_DISCARD)
- sv = NULL;
+ /* 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 = HeVAL(entry);
+ HeVAL(entry) = &PL_sv_placeholder;
+ if (sv) {
+ /* deletion of method from stash */
+ if (isGV(sv) && isGV_with_GP(sv) && GvCVu(sv)
+ && HvENAME_get(hv))
+ mro_method_changed_in(hv);
+ SvREFCNT_dec(sv);
+ sv = NULL;
+ }
+ }
else {
sv = sv_2mortal(HeVAL(entry));
HeVAL(entry) = &PL_sv_placeholder;
* we can still access via not-really-existing key without raising
* an error.
*/
- if (SvREADONLY(hv)) {
- SvREFCNT_dec(HeVAL(entry));
- HeVAL(entry) = &PL_sv_placeholder;
+ if (SvREADONLY(hv))
/* We'll be saving this slot, so the number of allocated keys
* doesn't go down, but the number placeholders goes up */
HvPLACEHOLDERS(hv)++;
- } else {
+ else {
*oentry = HeNEXT(entry);
if (SvOOK(hv) && entry == HvAUX(hv)->xhv_eiter /* HvEITER(hv) */)
HvLAZYDEL_on(hv);
- else
+ else {
+ if (SvOOK(hv) && HvLAZYDEL(hv) &&
+ entry == HeNEXT(HvAUX(hv)->xhv_eiter))
+ HeNEXT(HvAUX(hv)->xhv_eiter) = HeNEXT(entry);
hv_free_ent(hv, entry);
+ }
xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
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)) {
register I32 i;
char *a = (char*) HvARRAY(hv);
register HE **aep;
- register HE **oentry;
int longest_chain = 0;
int was_shared;
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;
for (i=0; i<oldsize; i++,aep++) {
int left_length = 0;
int right_length = 0;
- register HE *entry;
+ HE **oentry = aep;
+ HE *entry = *aep;
register HE **bep;
- if (!*aep) /* non-existent */
+ if (!entry) /* non-existent */
continue;
bep = aep+oldsize;
- for (oentry = aep, entry = *aep; entry; entry = *oentry) {
+ do {
if ((HeHASH(entry) & newsize) != (U32)i) {
*oentry = HeNEXT(entry);
HeNEXT(entry) = *bep;
*bep = entry;
right_length++;
- continue;
}
else {
oentry = &HeNEXT(entry);
left_length++;
}
- }
+ entry = *oentry;
+ } while (entry);
/* I think we don't actually need to keep track of the longest length,
merely flag if anything is too long. But for the moment while
developing this code I'll track it. */
register I32 i;
register char *a;
register HE **aep;
- register HE *entry;
- register HE **oentry;
PERL_ARGS_ASSERT_HV_KSPLIT;
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*/
aep = (HE**)a;
for (i=0; i<oldsize; i++,aep++) {
- if (!*aep) /* non-existent */
+ HE **oentry = aep;
+ HE *entry = *aep;
+
+ if (!entry) /* non-existent */
continue;
- for (oentry = aep, entry = *aep; entry; entry = *oentry) {
+ do {
register I32 j = (HeHASH(entry) & newsize);
if (j != i) {
*oentry = HeNEXT(entry);
HeNEXT(entry) = aep[j];
aep[j] = entry;
- continue;
}
else
oentry = &HeNEXT(entry);
- }
+ entry = *oentry;
+ } while (entry);
}
}
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)
{
while ((entry = hv_iternext_flags(ohv, 0))) {
SV *const sv = newSVsv(HeVAL(entry));
SV *heksv = newSVhek(HeKEY_hek(entry));
- sv_magic(sv, NULL, PERL_MAGIC_hintselem,
+ if (sv) sv_magic(sv, NULL, PERL_MAGIC_hintselem,
(char *)heksv, HEf_SVKEY);
SvREFCNT_dec(heksv);
(void)hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
return hv;
}
-void
-Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
+/* like hv_free_ent, but returns the SV rather than freeing it */
+STATIC SV*
+S_hv_free_ent_ret(pTHX_ HV *hv, register HE *entry)
{
dVAR;
SV *val;
- PERL_ARGS_ASSERT_HV_FREE_ENT;
+ PERL_ARGS_ASSERT_HV_FREE_ENT_RET;
if (!entry)
- return;
+ return NULL;
val = HeVAL(entry);
- if (HvNAME(hv) && anonymise_cv(HvNAME_HEK(hv), val) && GvCVu(val))
- mro_method_changed_in(hv);
- SvREFCNT_dec(val);
+ if (val && isGV(val) && isGV_with_GP(val) && GvCVu(val) && HvENAME(hv))
+ mro_method_changed_in(hv); /* deletion of method from stash */
if (HeKLEN(entry) == HEf_SVKEY) {
SvREFCNT_dec(HeKEY_sv(entry));
Safefree(HeKEY_hek(entry));
else
Safefree(HeKEY_hek(entry));
del_HE(entry);
+ return val;
}
-static I32
-S_anonymise_cv(pTHX_ HEK *stash, SV *val)
-{
- CV *cv;
- PERL_ARGS_ASSERT_ANONYMISE_CV;
+void
+Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
+{
+ dVAR;
+ SV *val;
- if (val && isGV(val) && isGV_with_GP(val) && (cv = GvCV(val))) {
- if ((SV *)CvGV(cv) == val) {
- GV *anongv;
+ PERL_ARGS_ASSERT_HV_FREE_ENT;
- if (stash) {
- SV *gvname = newSVhek(stash);
- sv_catpvs(gvname, "::__ANON__");
- anongv = gv_fetchsv(gvname, GV_ADDMULTI, SVt_PVCV);
- SvREFCNT_dec(gvname);
- } else {
- anongv = gv_fetchpvs("__ANON__::__ANON__", GV_ADDMULTI,
- SVt_PVCV);
- }
- CvGV(cv) = anongv;
- CvANON_on(cv);
- return 1;
- }
- }
- return 0;
+ if (!entry)
+ return;
+ val = hv_free_ent_ret(hv, entry);
+ SvREFCNT_dec(val);
}
+
void
Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
{
/*
=for apidoc hv_clear
-Clears a hash, making it empty.
+Frees the all the elements of a hash, leaving it empty.
+The XS equivalent of %hash = (). See also L</hv_undef>.
=cut
*/
for (; entry; entry = HeNEXT(entry)) {
/* not already placeholder */
if (HeVAL(entry) != &PL_sv_placeholder) {
- if (HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
+ if (HeVAL(entry) && SvREADONLY(HeVAL(entry))
+ && !SvIsCOW(HeVAL(entry))) {
SV* const keysv = hv_iterkeysv(entry);
Perl_croak(aTHX_
"Attempt to delete readonly key '%"SVf"' from a restricted hash",
}
}
}
- 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;
*oentry = HeNEXT(entry);
if (entry == HvEITER_get(hv))
HvLAZYDEL_on(hv);
- else
+ else {
+ if (SvOOK(hv) && HvLAZYDEL(hv) &&
+ entry == HeNEXT(HvAUX(hv)->xhv_eiter))
+ HeNEXT(HvAUX(hv)->xhv_eiter) = HeNEXT(entry);
hv_free_ent(hv, 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 index = 0;
+ XPVHV * const xhv = (XPVHV*)SvANY(hv);
+ SV *sv;
PERL_ARGS_ASSERT_HFREEENTRIES;
- if (!orig_array)
- return;
-
- if (HvNAME(hv) && orig_array != NULL) {
- /* symbol table: make all the contained subs ANON */
- STRLEN i;
- XPVHV *xhv = (XPVHV*)SvANY(hv);
-
- for (i = 0; i <= xhv->xhv_max; i++) {
- HE *entry = (HvARRAY(hv))[i];
- for (; entry; entry = HeNEXT(entry)) {
- SV *val = HeVAL(entry);
- /* we need to put the subs in the __ANON__ symtable, as
- * this one is being cleared. */
- anonymise_cv(NULL, val);
- }
- }
- }
-
- 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;
+ while ((sv = Perl_hfree_next_entry(aTHX_ hv, &index))||xhv->xhv_keys) {
+ SvREFCNT_dec(sv);
}
+}
- /* 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. */
-
- 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);
- /* If there are weak references to this HV, we need to avoid
- freeing them up here. In particular we need to keep the AV
- visible as what we're deleting might well have weak references
- back to this HV, so the for loop below may well trigger
- the removal of backreferences from this array. */
-
- if (iter->xhv_backreferences) {
- /* So donate them to regular backref magic to keep them safe.
- 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);
- }
- iter->xhv_backreferences = NULL;
- }
-
- entry = iter->xhv_eiter; /* HvEITER(hv) */
- if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
- HvLAZYDEL_off(hv);
- hv_free_ent(hv, entry);
- }
- 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 recusively mess with us */
- HvARRAY(hv) = NULL;
- ((XPVHV*) SvANY(hv))->xhv_keys = 0;
+/* hfree_next_entry()
+ * For use only by S_hfreeentries() and sv_clear().
+ * Delete the next available HE from hv and return the associated SV.
+ * Returns null on empty hash. Nevertheless null is not a reliable
+ * indicator that the hash is empty, as the deleted entry may have a
+ * null value.
+ * indexp is a pointer to the current index into HvARRAY. The index should
+ * initially be set to 0. hfree_next_entry() may update it. */
- 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);
+SV*
+Perl_hfree_next_entry(pTHX_ HV *hv, STRLEN *indexp)
+{
+ struct xpvhv_aux *iter;
+ HE *entry;
+ HE ** array;
+#ifdef DEBUGGING
+ STRLEN orig_index = *indexp;
+#endif
- /* 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);
- }
+ PERL_ARGS_ASSERT_HFREE_NEXT_ENTRY;
- if (!HvARRAY(hv)) {
- /* Good. No-one added anything this time round. */
- break;
+ 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 (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);
- }
- }
+ if (!((XPVHV*)SvANY(hv))->xhv_keys)
+ return NULL;
- if (--attempts == 0) {
- Perl_die(aTHX_ "panic: hfreeentries failed to free hash - something is repeatedly re-creating entries");
+ array = HvARRAY(hv);
+ assert(array);
+ while ( ! ((entry = array[*indexp])) ) {
+ if ((*indexp)++ >= HvMAX(hv))
+ *indexp = 0;
+ assert(*indexp != orig_index);
+ }
+ array[*indexp] = HeNEXT(entry);
+ ((XPVHV*) SvANY(hv))->xhv_keys--;
+
+ if ( PL_phase != PERL_PHASE_DESTRUCT && HvENAME(hv)
+ && 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
+ );
}
}
-
- 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;
- }
+ return hv_free_ent_ret(hv, entry);
}
+
/*
=for apidoc hv_undef
-Undefines the hash.
+Undefines the hash. The XS equivalent of undef(%hash).
+
+As well as freeing all the elements of the hash (like hv_clear()), this
+also frees any auxiliary data and storage associated with the hash.
+See also L</hv_clear>.
=cut
*/
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. */
+ /* note that the code following prior to hfreeentries is duplicated
+ * in sv_clear(), and changes here should be done there too */
+ if (PL_phase != PERL_PHASE_DESTRUCT && (name = HvNAME(hv))) {
if (PL_stashcache)
- (void)hv_delete(PL_stashcache, name, HvNAMELEN_get(hv), G_DISCARD);
+ (void)hv_delete(PL_stashcache, name,
+ HEK_UTF8(HvNAME_HEK(hv)) ? -HvNAMELEN_get(hv) : 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,
+ HEK_UTF8(HvENAME_HEK(hv)) ? -HvENAMELEN_get(hv) : 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, (HEK_UTF8(HvNAME_HEK(hv)) ? -HvNAMELEN_get(hv) : 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;
+ }
+ 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))
PERL_ARGS_ASSERT_HV_FILL;
if (ents) {
- HE *const *const end = ents + HvMAX(hv);
+ HE *const *const last = ents + HvMAX(hv);
+ count = last + 1 - ents;
do {
- if (*ents)
- ++count;
- } while (++ents <= end);
+ if (!*ents)
+ --count;
+ } while (++ents <= last);
}
return count;
}
+ sizeof(struct xpvhv_aux), char);
}
HvARRAY(hv) = (HE**) array;
- /* SvOOK_on(hv) attacks the IV flags. */
- SvFLAGS(hv) |= SVf_OOK;
+ SvOOK_on(hv);
iter = HvAUX(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 (len > I32_MAX)
Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
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, flags & SVf_UTF8 ? -(I32)len : (I32)len, hash) : NULL;
+}
+
+/*
+This is basically sv_eq_flags() in sv.c, but we avoid the magic
+and bytes checking.
+*/
+
+STATIC I32
+hek_eq_pvn_flags(pTHX_ const HEK *hek, const char* pv, const I32 pvlen, const U32 flags) {
+ if ( (HEK_UTF8(hek) ? 1 : 0) != (flags & SVf_UTF8 ? 1 : 0) ) {
+ if (flags & SVf_UTF8)
+ return (bytes_cmp_utf8(
+ (const U8*)HEK_KEY(hek), HEK_LEN(hek),
+ (const U8*)pv, pvlen) == 0);
+ else
+ return (bytes_cmp_utf8(
+ (const U8*)pv, pvlen,
+ (const U8*)HEK_KEY(hek), HEK_LEN(hek)) == 0);
+ }
+ else
+ return HEK_LEN(hek) == pvlen && ((HEK_KEY(hek) == pv)
+ || memEQ(HEK_KEY(hek), pv, pvlen));
+}
+
+/*
+=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;
+
+ 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_UTF8(*hekp) || (flags & SVf_UTF8))
+ ? hek_eq_pvn_flags(aTHX_ *hekp, name, (I32)len, flags)
+ : (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, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
+ }
+ else {
+ HEK *existing_name = aux->xhv_name_u.xhvnameu_name;
+ if (
+ existing_name && (
+ (HEK_UTF8(existing_name) || (flags & SVf_UTF8))
+ ? hek_eq_pvn_flags(aTHX_ existing_name, name, (I32)len, flags)
+ : (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, (flags & SVf_UTF8 ? -(I32)len : (I32)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;
+
+ 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_UTF8(*victim) || (flags & SVf_UTF8))
+ ? hek_eq_pvn_flags(aTHX_ *victim, name, (I32)len, flags)
+ : (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_UTF8(*namep) || (flags & SVf_UTF8))
+ ? hek_eq_pvn_flags(aTHX_ *namep, name, (I32)len, flags)
+ : (HEK_LEN(*namep) == (I32)len && memEQ(HEK_KEY(*namep), name, len))
+ ) {
+ aux->xhv_name_count = -count;
+ }
+ }
+ else if(
+ (HEK_UTF8(aux->xhv_name_u.xhvnameu_name) || (flags & SVf_UTF8))
+ ? hek_eq_pvn_flags(aTHX_ aux->xhv_name_u.xhvnameu_name, name, (I32)len, flags)
+ : (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 **
if (av) {
HvAUX(hv)->xhv_backreferences = 0;
Perl_sv_kill_backrefs(aTHX_ MUTABLE_SV(hv), av);
- SvREFCNT_dec(av);
+ if (SvTYPE(av) == SVt_PVAV)
+ SvREFCNT_dec(av);
}
}
}
#endif
- /* hv_iterint now ensures this. */
+ /* hv_iterinit now ensures this. */
assert (HvARRAY(hv));
/* At start of hash, entry is NULL. */
or if we run through it and find only placeholders. */
}
}
+ else iter->xhv_riter = -1;
if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */
HvLAZYDEL_off(hv);
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) {
if (!entry)
Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
- "Attempt to free non-existent shared string '%s'%s"
+ "Attempt to free nonexistent shared string '%s'%s"
pTHX__FORMAT,
hek ? HEK_KEY(hek) : str,
((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE);
/* If we found we were able to downgrade the string to bytes, then
we should flag that it needs upgrading on keys or each. Also flag
that we need share_hek_flags to free the string. */
- if (str != save)
+ if (str != save) {
+ PERL_HASH(hash, str, len);
flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
+ }
}
return share_hek_flags (str, len, hash, flags);
/* We don't actually store a HE from the arena and a regular HEK.
Instead we allocate one chunk of memory big enough for both,
and put the HEK straight after the HE. This way we can find the
- HEK directly from the HE.
+ HE directly from the HEK.
*/
Newx(k, STRUCT_OFFSET(struct shared_he,
xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
if (!next) { /* initial entry? */
- } else if (xhv->xhv_keys > (IV)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.
+
+=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);
+}
-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.
+/*
+=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)
+{
+ dVAR;
+ if (he) {
+ HINTS_REFCNT_LOCK;
+ he->refcounted_he_refcnt++;
+ HINTS_REFCNT_UNLOCK;
+ }
+ return he;
+}
+
+/*
+=for apidoc cop_fetch_label
+
+Returns the label attached to a cop.
+The flags pointer may be set to C<SVf_UTF8> or 0.
+
+=cut
+*/
+
/* 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_cop_fetch_label(pTHX_ COP *const cop, STRLEN *len, U32 *flags) {
+ struct refcounted_he *const chain = cop->cop_hints_hash;
+
+ PERL_ARGS_ASSERT_COP_FETCH_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)
-{
- PERL_ARGS_ASSERT_STORE_COP_LABEL;
+/*
+=for apidoc cop_store_label
+
+Save a label into a C<cop_hints_hash>. You need to set flags to C<SVf_UTF8>
+for a utf-8 label.
- return refcounted_he_new_common(chain, ":", 1, HVrhek_PV, HVrhek_PV,
- label, strlen(label));
+=cut
+*/
+
+void
+Perl_cop_store_label(pTHX_ COP *const cop, const char *label, STRLEN len,
+ U32 flags)
+{
+ SV *labelsv;
+ PERL_ARGS_ASSERT_COP_STORE_LABEL;
+
+ if (flags & ~(SVf_UTF8))
+ Perl_croak(aTHX_ "panic: cop_store_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