/*
=head1 Hash Manipulation Functions
-A HV structure represents a Perl hash. It consists mainly of an array
-of pointers, each of which points to a linked list of HE structures. The
+A HV structure represents a Perl hash. It consists mainly of an array
+of pointers, each of which points to a linked list of HE structures. The
array is indexed by the hash function of the key, so each linked list
-represents all the hash entries with the same hash value. Each HE contains
+represents all the hash entries with the same hash value. Each HE contains
a pointer to the actual value, plus a pointer to a HEK structure which
holds the key and hash value.
#define PERL_HASH_INTERNAL_ACCESS
#include "perl.h"
-#define HV_MAX_LENGTH_BEFORE_SPLIT 14
+#define DO_HSPLIT(xhv) ((xhv)->xhv_keys > (xhv)->xhv_max) /* HvTOTALKEYS(hv) > HvMAX(hv) */
static const char S_strtab_error[]
= "Cannot modify shared string table in hv_%s";
{
const int flags_masked = flags & HVhek_MASK;
char *k;
- register HEK *hek;
+ HEK *hek;
PERL_ARGS_ASSERT_SAVE_HEK_FLAGS;
/*
=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. This means that if
+there is no value in the hash associated with the given key, then one is
+created and a pointer to it is returned. The C<SV*> it points to can be
+assigned to. But always 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.
=for apidoc hv_exists_ent
-Returns a boolean indicating whether the specified hash key exists. C<hash>
+Returns a boolean indicating whether
+the specified hash key exists. C<hash>
can be a valid precomputed hash value, or 0 to ask for it to be
computed.
void *
Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
- int flags, int action, SV *val, register U32 hash)
+ int flags, int action, SV *val, U32 hash)
{
dVAR;
XPVHV* xhv;
if (!hv)
return NULL;
- if (SvTYPE(hv) == SVTYPEMASK)
+ if (SvTYPE(hv) == (svtype)SVTYPEMASK)
return NULL;
assert(SvTYPE(hv) == SVt_PVHV);
if (SvIsCOW_shared_hash(keysv)) {
flags = HVhek_KEYCANONICAL | (is_utf8 ? HVhek_UTF8 : 0);
} else {
- flags = 0;
+ flags = is_utf8 ? HVhek_UTF8 : 0;
}
} else {
is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE);
if (action & HV_DELETE) {
return (void *) hv_delete_common(hv, keysv, key, klen,
- flags | (is_utf8 ? HVhek_UTF8 : 0),
- action, hash);
+ flags, action, hash);
}
xhv = (XPVHV*)SvANY(hv);
bool needs_store;
hv_magic_check (hv, &needs_copy, &needs_store);
if (needs_copy) {
- const bool save_taint = PL_tainted;
+ const bool save_taint = TAINT_get; /* Unused var warning under NO_TAINT_SUPPORT */
if (keysv || is_utf8) {
if (!keysv) {
keysv = newSVpvn_utf8(key, klen, TRUE);
}
- if (PL_tainting)
- PL_tainted = SvTAINTED(keysv);
+ if (TAINTING_get)
+ TAINT_set(SvTAINTED(keysv));
keysv = sv_2mortal(newSVsv(keysv));
mg_copy(MUTABLE_SV(hv), val, (char*)keysv, HEf_SVKEY);
} else {
}
}
- if (is_utf8 & !(flags & HVhek_KEYCANONICAL)) {
+ if (is_utf8 && !(flags & HVhek_KEYCANONICAL)) {
char * const keysave = (char *)key;
key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
if (is_utf8)
}
}
- 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;
+ if (!hash) {
+ if (keysv && (SvIsCOW_shared_hash(keysv)))
+ hash = SvSHARED_HASH(keysv);
+ else
+ PERL_HASH(hash, key, klen);
+ }
masked_flags = (flags & HVhek_MASK);
if (masked_flags & HVhek_ENABLEHVKFLAGS)
HvHASKFLAGS_on(hv);
- {
- const HE *counter = HeNEXT(entry);
-
- 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;
-
- while ((counter = HeNEXT(counter)))
- n_links++;
-
- if (n_links > HV_MAX_LENGTH_BEFORE_SPLIT) {
- hsplit(hv);
- }
- }
+ xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
+ if ( DO_HSPLIT(xhv) ) {
+ hsplit(hv);
}
if (return_svp) {
/*
=for apidoc hv_delete
-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.
+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
int k_flags, I32 d_flags, U32 hash)
{
dVAR;
- register XPVHV* xhv;
- register HE *entry;
- register HE **oentry;
+ XPVHV* xhv;
+ HE *entry;
+ HE **oentry;
bool is_utf8 = (k_flags & HVhek_UTF8) ? TRUE : FALSE;
int masked_flags;
if (!HvARRAY(hv))
return NULL;
- if (is_utf8) {
+ if (is_utf8 && !(k_flags & HVhek_KEYCANONICAL)) {
const char * const keysave = key;
key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
HvHASKFLAGS_on(MUTABLE_SV(hv));
}
- if (HvREHASH(hv) || (!hash && !(keysv && (SvIsCOW_shared_hash(keysv)))))
- PERL_HASH_INTERNAL_(hash, key, klen, HvREHASH(hv));
- else if (!hash)
- hash = SvSHARED_HASH(keysv);
+ if (!hash) {
+ if (keysv && (SvIsCOW_shared_hash(keysv)))
+ hash = SvSHARED_HASH(keysv);
+ else
+ PERL_HASH(hash, key, klen);
+ }
masked_flags = (k_flags & HVhek_MASK);
mro_changes = 1;
}
- if (d_flags & G_DISCARD) {
- sv = HeVAL(entry);
- 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));
+ sv = d_flags & G_DISCARD ? HeVAL(entry) : sv_2mortal(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);
+ }
/*
* If a restricted hash, rather than really deleting the entry, put
HvHASKFLAGS_off(hv);
}
+ if (d_flags & G_DISCARD) {
+ SvREFCNT_dec(sv);
+ sv = NULL;
+ }
+
if (mro_changes == 1) mro_isa_changed_in(hv);
else if (mro_changes == 2)
mro_package_moved(NULL, stash, gv, 1);
S_hsplit(pTHX_ HV *hv)
{
dVAR;
- register XPVHV* const xhv = (XPVHV*)SvANY(hv);
+ XPVHV* const xhv = (XPVHV*)SvANY(hv);
const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
- register I32 newsize = oldsize * 2;
- register I32 i;
+ I32 newsize = oldsize * 2;
+ I32 i;
char *a = (char*) HvARRAY(hv);
- register HE **aep;
- int longest_chain = 0;
- int was_shared;
+ HE **aep;
PERL_ARGS_ASSERT_HSPLIT;
aep = (HE**)a;
for (i=0; i<oldsize; i++,aep++) {
- int left_length = 0;
- int right_length = 0;
HE **oentry = aep;
HE *entry = *aep;
- register HE **bep;
+ HE **bep;
if (!entry) /* non-existent */
continue;
*oentry = HeNEXT(entry);
HeNEXT(entry) = *bep;
*bep = entry;
- right_length++;
}
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. */
- if (left_length > longest_chain)
- longest_chain = left_length;
- if (right_length > longest_chain)
- longest_chain = right_length;
- }
-
-
- /* Pick your policy for "hashing isn't working" here: */
- if (longest_chain <= HV_MAX_LENGTH_BEFORE_SPLIT /* split worked? */
- || HvREHASH(hv)) {
- return;
}
-
- if (hv == PL_strtab) {
- /* Urg. Someone is doing something nasty to the string table.
- Can't win. */
- return;
- }
-
- /* Awooga. Awooga. Pathological data. */
- /*PerlIO_printf(PerlIO_stderr(), "%p %d of %d with %d/%d buckets\n", (void*)hv,
- longest_chain, HvTOTALKEYS(hv), HvFILL(hv), 1+HvMAX(hv));*/
-
- ++newsize;
- Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
- + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
- if (SvOOK(hv)) {
- Copy(HvAUX(hv), &a[newsize * sizeof(HE*)], 1, struct xpvhv_aux);
- }
-
- was_shared = HvSHAREKEYS(hv);
-
- HvSHAREKEYS_off(hv);
- HvREHASH_on(hv);
-
- aep = HvARRAY(hv);
-
- for (i=0; i<newsize; i++,aep++) {
- register HE *entry = *aep;
- while (entry) {
- /* We're going to trash this HE's next pointer when we chain it
- into the new hash below, so store where we go next. */
- HE * const next = HeNEXT(entry);
- UV hash;
- HE **bep;
-
- /* Rehash it */
- PERL_HASH_INTERNAL(hash, HeKEY(entry), HeKLEN(entry));
-
- if (was_shared) {
- /* Unshare it. */
- HEK * const new_hek
- = save_hek_flags(HeKEY(entry), HeKLEN(entry),
- hash, HeKFLAGS(entry));
- unshare_hek (HeKEY_hek(entry));
- HeKEY_hek(entry) = new_hek;
- } else {
- /* Not shared, so simply write the new hash in. */
- HeHASH(entry) = hash;
- }
- /*PerlIO_printf(PerlIO_stderr(), "%d ", HeKFLAGS(entry));*/
- HEK_REHASH_on(HeKEY_hek(entry));
- /*PerlIO_printf(PerlIO_stderr(), "%d\n", HeKFLAGS(entry));*/
-
- /* Copy oentry to the correct new chain. */
- bep = ((HE**)a) + (hash & (I32) xhv->xhv_max);
- HeNEXT(entry) = *bep;
- *bep = entry;
-
- entry = next;
- }
- }
- Safefree (HvARRAY(hv));
- HvARRAY(hv) = (HE **)a;
}
void
Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
{
dVAR;
- register XPVHV* xhv = (XPVHV*)SvANY(hv);
+ XPVHV* xhv = (XPVHV*)SvANY(hv);
const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
- register I32 newsize;
- register I32 i;
- register char *a;
- register HE **aep;
+ I32 newsize;
+ I32 i;
+ char *a;
+ HE **aep;
PERL_ARGS_ASSERT_HV_KSPLIT;
if (!entry) /* non-existent */
continue;
do {
- register I32 j = (HeHASH(entry) & newsize);
+ I32 j = (HeHASH(entry) & newsize);
if (j != i) {
j -= i;
HV * const hv = newHV();
STRLEN hv_max;
- if (!ohv || !HvTOTALKEYS(ohv))
+ if (!ohv || (!HvTOTALKEYS(ohv) && !SvMAGICAL((const SV *)ohv)))
return hv;
hv_max = HvMAX(ohv);
hv_iterinit(ohv);
while ((entry = hv_iternext_flags(ohv, 0))) {
- SV *const val = HeVAL(entry);
- (void)hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
- SvIMMORTAL(val) ? val : newSVsv(val),
+ SV *val = hv_iterval(ohv,entry);
+ SV * const keysv = HeSVKEY(entry);
+ val = SvIMMORTAL(val) ? val : newSVsv(val);
+ if (keysv)
+ (void)hv_store_ent(hv, keysv, val, 0);
+ else
+ (void)hv_store_flags(hv, HeKEY(entry), HeKLEN(entry), val,
HeHASH(entry), HeKFLAGS(entry));
}
HvRITER_set(ohv, riter);
{
HV * const hv = newHV();
- if (ohv && HvTOTALKEYS(ohv)) {
+ if (ohv) {
STRLEN hv_max = HvMAX(ohv);
STRLEN hv_fill = HvFILL(ohv);
HE *entry;
const I32 riter = HvRITER_get(ohv);
HE * const eiter = HvEITER_get(ohv);
+ ENTER;
+ SAVEFREESV(hv);
+
while (hv_max && hv_max + 1 >= hv_fill * 2)
hv_max = hv_max / 2;
HvMAX(hv) = hv_max;
hv_iterinit(ohv);
while ((entry = hv_iternext_flags(ohv, 0))) {
- SV *const sv = newSVsv(HeVAL(entry));
- SV *heksv = newSVhek(HeKEY_hek(entry));
- sv_magic(sv, NULL, PERL_MAGIC_hintselem,
+ SV *const sv = newSVsv(hv_iterval(ohv,entry));
+ SV *heksv = HeSVKEY(entry);
+ if (!heksv && sv) heksv = newSVhek(HeKEY_hek(entry));
+ 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),
- sv, HeHASH(entry), HeKFLAGS(entry));
+ if (heksv == HeSVKEY(entry))
+ (void)hv_store_ent(hv, heksv, sv, 0);
+ else {
+ (void)hv_common(hv, heksv, HeKEY(entry), HeKLEN(entry),
+ HeKFLAGS(entry), HV_FETCH_ISSTORE|HV_FETCH_JUST_SV, sv, HeHASH(entry));
+ SvREFCNT_dec(heksv);
+ }
}
HvRITER_set(ohv, riter);
HvEITER_set(ohv, eiter);
+
+ SvREFCNT_inc_simple_void_NN(hv);
+ LEAVE;
}
hv_magic(hv, NULL, PERL_MAGIC_hints);
return hv;
/* 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)
+S_hv_free_ent_ret(pTHX_ HV *hv, HE *entry)
{
dVAR;
SV *val;
if (!entry)
return NULL;
val = HeVAL(entry);
- 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));
void
-Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
+Perl_hv_free_ent(pTHX_ HV *hv, HE *entry)
{
dVAR;
SV *val;
void
-Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
+Perl_hv_delayfree_ent(pTHX_ HV *hv, HE *entry)
{
dVAR;
=for apidoc hv_clear
Frees the all the elements of a hash, leaving it empty.
-The XS equivalent of %hash = (). See also L</hv_undef>.
+The XS equivalent of C<%hash = ()>. See also L</hv_undef>.
+
+If any destructors are triggered as a result, the hv itself may
+be freed.
=cut
*/
Perl_hv_clear(pTHX_ HV *hv)
{
dVAR;
- register XPVHV* xhv;
+ XPVHV* xhv;
if (!hv)
return;
xhv = (XPVHV*)SvANY(hv);
+ ENTER;
+ SAVEFREESV(SvREFCNT_inc_simple_NN(hv));
if (SvREADONLY(hv) && HvARRAY(hv) != NULL) {
/* restricted hash: convert all keys to placeholders */
STRLEN i;
mg_clear(MUTABLE_SV(hv));
HvHASKFLAGS_off(hv);
- HvREHASH_off(hv);
}
if (SvOOK(hv)) {
if(HvENAME_get(hv))
mro_isa_changed_in(hv);
HvEITER_set(hv, NULL);
}
+ LEAVE;
}
/*
{
STRLEN index = 0;
XPVHV * const xhv = (XPVHV*)SvANY(hv);
+ SV *sv;
PERL_ARGS_ASSERT_HFREEENTRIES;
- while (xhv->xhv_keys) {
- SvREFCNT_dec(Perl_hfree_next_entry(aTHX_ hv, &index));
+ while ((sv = Perl_hfree_next_entry(aTHX_ hv, &index))||xhv->xhv_keys) {
+ SvREFCNT_dec(sv);
}
}
/*
=for apidoc hv_undef
-Undefines the hash. The XS equivalent of undef(%hash).
+Undefines the hash. The XS equivalent of C<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.
+
+If any destructors are triggered as a result, the hv itself may
+be freed.
+
See also L</hv_clear>.
=cut
Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags)
{
dVAR;
- register XPVHV* xhv;
+ XPVHV* xhv;
const char *name;
+ const bool save = !!SvREFCNT(hv);
if (!hv)
return;
/* 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);
+ if (PL_stashcache) {
+ DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for '%"
+ HEKf"'\n", HvNAME_HEK(hv)));
+ (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);
}
+ if (save) {
+ ENTER;
+ SAVEFREESV(SvREFCNT_inc_simple_NN(hv));
+ }
hfreeentries(hv);
if (SvOOK(hv)) {
struct xpvhv_aux * const aux = HvAUX(hv);
if ((name = HvENAME_get(hv))) {
if (PL_phase != PERL_PHASE_DESTRUCT)
mro_isa_changed_in(hv);
- if (PL_stashcache)
+ if (PL_stashcache) {
+ DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for effective name '%"
+ HEKf"'\n", HvENAME_HEK(hv)));
(void)hv_delete(
- PL_stashcache, name, HvENAMELEN_get(hv), G_DISCARD
+ 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, HvNAMELEN_get(hv), G_DISCARD);
+ if (name && PL_stashcache) {
+ DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for name '%"
+ HEKf"'\n", HvNAME_HEK(hv)));
+ (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) {
+ SvREFCNT_dec_NN(meta->mro_linear_all);
+ /* mro_linear_current is just acting as a shortcut pointer,
+ hence the else. */
+ }
+ else
/* 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->mro_nextmethod);
SvREFCNT_dec(meta->isa);
Safefree(meta);
aux->xhv_mro_meta = NULL;
}
+ SvREFCNT_dec(aux->xhv_super);
if (!aux->xhv_name_u.xhvnameu_name && ! aux->xhv_backreferences)
SvFLAGS(hv) &= ~SVf_OOK;
}
xhv->xhv_max = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
HvARRAY(hv) = 0;
}
- HvPLACEHOLDERS_set(hv, 0);
+ /* if we're freeing the HV, the SvMAGIC field has been reused for
+ * other purposes, and so there can't be any placeholder magic */
+ if (SvREFCNT(hv))
+ HvPLACEHOLDERS_set(hv, 0);
if (SvRMAGICAL(hv))
mg_clear(MUTABLE_SV(hv));
+ if (save) LEAVE;
}
/*
+ 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_name_count = 0;
iter->xhv_backreferences = 0;
iter->xhv_mro_meta = NULL;
+ iter->xhv_super = NULL;
return iter;
}
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);
spot = &iter->xhv_name_u.xhvnameu_name;
}
PERL_HASH(hash, name, len);
- *spot = 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
+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
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);
HEK **hekp = xhv_name + (count < 0 ? -count : count);
while (hekp-- > xhv_name)
if (
- HEK_LEN(*hekp) == (I32)len && memEQ(HEK_KEY(*hekp), name, len)
- ) {
+ (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, len, hash);
+ (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_LEN(existing_name) == (I32)len
- && memEQ(HEK_KEY(existing_name), name, len)
+ 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, len, hash);
+ (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
+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).
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);
HEK **victim = namep + (count < 0 ? -count : count);
while (victim-- > namep + 1)
if (
- HEK_LEN(*victim) == (I32)len
- && memEQ(HEK_KEY(*victim), name, len)
+ (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;
return;
}
if (
- count > 0 && HEK_LEN(*namep) == (I32)len
- && memEQ(HEK_KEY(*namep),name,len)
+ 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_LEN(aux->xhv_name_u.xhvnameu_name) == (I32)len
- && memEQ(HEK_KEY(aux->xhv_name_u.xhvnameu_name), name, len)
+ (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 *);
HvAUX(hv)->xhv_backreferences = 0;
Perl_sv_kill_backrefs(aTHX_ MUTABLE_SV(hv), av);
if (SvTYPE(av) == SVt_PVAV)
- SvREFCNT_dec(av);
+ SvREFCNT_dec_NN(av);
}
}
set the placeholders keys (for restricted hashes) will be returned in addition
to normal keys. By default placeholders are automatically skipped over.
Currently a placeholder is implemented with a value that is
-C<&Perl_sv_placeholder>. Note that the implementation of placeholders and
+C<&PL_sv_placeholder>. Note that the implementation of placeholders and
restricted hashes may change, and the implementation currently is
insufficiently abstracted for any change to be tidy.
Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
{
dVAR;
- register XPVHV* xhv;
- register HE *entry;
+ XPVHV* xhv;
+ HE *entry;
HE *oldentry;
MAGIC* mg;
struct xpvhv_aux *iter;
if (!SvOOK(hv)) {
/* Too many things (well, pp_each at least) merrily assume that you can
- call iv_iternext without calling hv_iterinit, so we'll have to deal
+ call hv_iternext without calling hv_iterinit, so we'll have to deal
with it. */
hv_iterinit(hv);
}
if (entry) {
sv_setsv(key, HeSVKEY_force(entry));
SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
+ HeSVKEY_set(entry, NULL);
}
else {
char *k;
/* one HE per MAGICAL hash */
iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
+ HvLAZYDEL_on(hv); /* make sure entry gets freed */
Zero(entry, 1, HE);
Newxz(k, HEK_BASESIZE + sizeof(const SV *), char);
hek = (HEK*)k;
Safefree(HeKEY_hek(entry));
del_HE(entry);
iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
+ HvLAZYDEL_off(hv);
return NULL;
}
}
}
#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);
hv_free_ent(hv, oldentry);
}
- /*if (HvREHASH(hv) && entry && !HeKREHASH(entry))
- PerlIO_printf(PerlIO_stderr(), "Awooga %p %p\n", (void*)hv, (void*)entry);*/
-
iter->xhv_eiter = entry; /* HvEITER(hv) = entry */
return entry;
}
*/
char *
-Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
+Perl_hv_iterkey(pTHX_ HE *entry, I32 *retlen)
{
PERL_ARGS_ASSERT_HV_ITERKEY;
*/
SV *
-Perl_hv_iterkeysv(pTHX_ register HE *entry)
+Perl_hv_iterkeysv(pTHX_ HE *entry)
{
PERL_ARGS_ASSERT_HV_ITERKEYSV;
*/
SV *
-Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
+Perl_hv_iterval(pTHX_ HV *hv, HE *entry)
{
PERL_ARGS_ASSERT_HV_ITERVAL;
S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash)
{
dVAR;
- register XPVHV* xhv;
+ XPVHV* xhv;
HE *entry;
- register HE **oentry;
+ HE **oentry;
bool is_utf8 = FALSE;
int k_flags = 0;
const char * const save = str;
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);
* len and hash must both be valid for str.
*/
HEK *
-Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
+Perl_share_hek(pTHX_ const char *str, I32 len, U32 hash)
{
bool is_utf8 = FALSE;
int flags = 0;
/* 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) {
+ dVAR;
+ PERL_HASH(hash, str, len);
flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
+ }
}
return share_hek_flags (str, len, hash, flags);
}
STATIC HEK *
-S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
+S_share_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags)
{
dVAR;
- register HE *entry;
+ HE *entry;
const int flags_masked = flags & HVhek_MASK;
const U32 hindex = hash & (I32) HvMAX(PL_strtab);
- register XPVHV * const xhv = (XPVHV*)SvANY(PL_strtab);
+ XPVHV * const xhv = (XPVHV*)SvANY(PL_strtab);
PERL_ARGS_ASSERT_SHARE_HEK_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 > xhv->xhv_max /* HvUSEDKEYS(hv) > HvMAX(hv) */) {
- hsplit(PL_strtab);
+ } else if ( DO_HSPLIT(xhv) ) {
+ hsplit(PL_strtab);
}
}
U8 utf8_flag;
PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PVN;
- if (flags & ~REFCOUNTED_HE_KEY_UTF8)
+ if (flags & ~(REFCOUNTED_HE_KEY_UTF8|REFCOUNTED_HE_EXISTS))
Perl_croak(aTHX_ "panic: refcounted_he_fetch_pvn bad flags %"UVxf,
(UV)flags);
if (!chain)
memEQ(HEK_KEY(chain->refcounted_he_hek), keypv, keylen) &&
utf8_flag == (HEK_FLAGS(chain->refcounted_he_hek) & HVhek_UTF8)
#endif
- )
+ ) {
+ if (flags & REFCOUNTED_HE_EXISTS)
+ return (chain->refcounted_he_data[0] & HVrhek_typemask)
+ == HVrhek_delete
+ ? NULL : &PL_sv_yes;
return sv_2mortal(refcounted_he_value(chain));
+ }
}
- return &PL_sv_placeholder;
+ return flags & REFCOUNTED_HE_EXISTS ? NULL : &PL_sv_placeholder;
}
/*
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_ COP *const cop, 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_FETCH_COP_LABEL;
+ PERL_ARGS_ASSERT_COP_FETCH_LABEL;
if (!chain)
return NULL;
return chain->refcounted_he_data + 1;
}
+/*
+=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.
+
+=cut
+*/
+
void
-Perl_store_cop_label(pTHX_ COP *const cop, const char *label, STRLEN len,
+Perl_cop_store_label(pTHX_ COP *const cop, const char *label, STRLEN len,
U32 flags)
{
SV *labelsv;
- PERL_ARGS_ASSERT_STORE_COP_LABEL;
+ PERL_ARGS_ASSERT_COP_STORE_LABEL;
if (flags & ~(SVf_UTF8))
- Perl_croak(aTHX_ "panic: store_cop_label illegal flag bits 0x%" UVxf,
+ 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)
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff