STATIC HEK *
S_save_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags)
{
+ int flags_masked = flags & HVhek_MASK;
char *k;
register HEK *hek;
HEK_KEY(hek)[len] = 0;
HEK_LEN(hek) = len;
HEK_HASH(hek) = hash;
- HEK_FLAGS(hek) = (unsigned char)flags;
+ HEK_FLAGS(hek) = (unsigned char)flags_masked;
+
+ if (flags & HVhek_FREEKEY)
+ Safefree(str);
return hek;
}
/* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
* contains an SV* */
+#define HV_FETCH_ISSTORE 0x01
+#define HV_FETCH_ISEXISTS 0x02
+#define HV_FETCH_LVALUE 0x04
+#define HV_FETCH_JUST_SV 0x08
+
+/*
+=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
+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
+responsible for suitably incrementing the reference count of C<val> before
+the call, and decrementing it if the function returned NULL. Effectively
+a successful hv_store takes ownership of one reference to C<val>. This is
+usually what you want; a newly created SV has a reference count of one, so
+if all your code does is create SVs then store them in a hash, hv_store
+will own the only reference to the new SV, and your code doesn't need to do
+anything further to tidy up. hv_store is not implemented as a call to
+hv_store_ent, and does not create a temporary SV for the key, so if your
+key data is not already in SV form then use hv_store in preference to
+hv_store_ent.
+
+See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
+information on how to use this function on tied hashes.
+
+=cut
+*/
+
+SV**
+Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen_i32, SV *val, U32 hash)
+{
+ HE *hek;
+ STRLEN klen;
+ int flags;
+
+ if (klen_i32 < 0) {
+ klen = -klen_i32;
+ flags = HVhek_UTF8;
+ } else {
+ klen = klen_i32;
+ flags = 0;
+ }
+ hek = hv_fetch_common (hv, NULL, key, klen, flags,
+ (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, 0);
+ return hek ? &HeVAL(hek) : NULL;
+}
+
+SV**
+Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val,
+ register U32 hash, int flags)
+{
+ HE *hek = hv_fetch_common (hv, NULL, key, klen, flags,
+ (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash);
+ return hek ? &HeVAL(hek) : NULL;
+}
+
+/*
+=for apidoc hv_store_ent
+
+Stores C<val> in a hash. The hash key is specified as C<key>. The C<hash>
+parameter is the precomputed hash value; if it is zero then Perl will
+compute it. The return value is the new hash entry so created. It 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 the
+contents of the return value can be accessed using the C<He?> macros
+described here. Note that the caller is responsible for suitably
+incrementing the reference count of C<val> before the call, and
+decrementing it if the function returned NULL. Effectively a successful
+hv_store_ent takes ownership of one reference to C<val>. This is
+usually what you want; a newly created SV has a reference count of one, so
+if all your code does is create SVs then store them in a hash, hv_store
+will own the only reference to the new SV, and your code doesn't need to do
+anything further to tidy up. Note that hv_store_ent only reads the C<key>;
+unlike C<val> it does not take ownership of it, so maintaining the correct
+reference count on C<key> is entirely the caller's responsibility. hv_store
+is not implemented as a call to hv_store_ent, and does not create a temporary
+SV for the key, so if your key data is not already in SV form then use
+hv_store in preference to hv_store_ent.
+
+See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
+information on how to use this function on tied hashes.
+
+=cut
+*/
+
+HE *
+Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, U32 hash)
+{
+ return hv_fetch_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISSTORE, val, hash);
+}
+
+/*
+=for apidoc hv_exists
+
+Returns a boolean indicating whether the specified hash key exists. The
+C<klen> is the length of the key.
+
+=cut
+*/
+
+bool
+Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen_i32)
+{
+ STRLEN klen;
+ int flags;
+
+ if (klen_i32 < 0) {
+ klen = -klen_i32;
+ flags = HVhek_UTF8;
+ } else {
+ klen = klen_i32;
+ flags = 0;
+ }
+ return hv_fetch_common(hv, NULL, key, klen, flags, HV_FETCH_ISEXISTS, 0, 0)
+ ? TRUE : FALSE;
+}
+
/*
=for apidoc hv_fetch
=cut
*/
-#define HV_FETCH_ISSTORE 0x01
-#define HV_FETCH_ISEXISTS 0x02
-#define HV_FETCH_LVALUE 0x04
-#define HV_FETCH_JUST_SV 0x08
-
SV**
Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 lval)
{
return hek ? &HeVAL(hek) : NULL;
}
+/*
+=for apidoc hv_exists_ent
+
+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.
+
+=cut
+*/
+
+bool
+Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
+{
+ return hv_fetch_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISEXISTS, 0, hash)
+ ? TRUE : FALSE;
+}
+
/* returns an HE * structure with the all fields set */
/* note that hent_val will be a mortal sv for MAGICAL hashes */
/*
(lval ? HV_FETCH_LVALUE : 0), Nullsv, hash);
}
-HE *
+STATIC HE *
S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
int flags, int action, SV *val, register U32 hash)
{
return 0;
if (keysv) {
+ if (flags & HVhek_FREEKEY)
+ Safefree(key);
key = SvPV(keysv, klen);
flags = 0;
is_utf8 = (SvUTF8(keysv) != 0);
U32 i;
for (i = 0; i < klen; ++i)
if (isLOWER(key[i])) {
- const char *keysave = key;
- /* Will need to free this, so set FREEKEY flag
- on call to hv_fetch_common. */
- key = savepvn(key,klen);
- key = (const char*)strupr((char*)key);
-
- if (flags & HVhek_FREEKEY)
- Safefree(keysave);
-
- /* This isn't strictly the same as the old hv_fetch
- magic, which made a call to hv_fetch, followed
- by a call to hv_store if that failed and lvalue
- was true.
- Which I believe could have been done by simply
- passing the lvalue through to the first hv_fetch.
- So I will do that here. */
- return hv_fetch_common(hv, Nullsv, key, klen,
- HVhek_FREEKEY,
- action, Nullsv, 0);
+ /* Would be nice if we had a routine to do the
+ copy and upercase in a single pass through. */
+ char *nkey = strupr(savepvn(key,klen));
+ /* Note that this fetch is for nkey (the uppercased
+ key) whereas the store is for key (the original) */
+ entry = hv_fetch_common(hv, Nullsv, nkey, klen,
+ HVhek_FREEKEY, /* free nkey */
+ 0 /* non-LVAL fetch */,
+ Nullsv /* no value */,
+ 0 /* compute hash */);
+ if (!entry && (action & HV_FETCH_LVALUE)) {
+ /* This call will free key if necessary.
+ Do it this way to encourage compiler to tail
+ call optimise. */
+ entry = hv_fetch_common(hv, keysv, key, klen,
+ flags, HV_FETCH_ISSTORE,
+ NEWSV(61,0), hash);
+ } else {
+ if (flags & HVhek_FREEKEY)
+ Safefree(key);
+ }
+ return entry;
}
}
#endif
else
#endif
{
- /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
- oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
- entry = *oentry;
+ /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
+ entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
}
for (; entry; ++n_links, entry = HeNEXT(entry)) {
if (HeHASH(entry) != hash) /* strings can't be equal */
return entry;
}
#ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
- if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
+ if (!(action & HV_FETCH_ISSTORE)
+ && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
unsigned long len;
char *env = PerlEnv_ENVgetenv_len(key,&len);
if (env) {
sv = newSVpvn(env,len);
SvTAINTED_on(sv);
- return hv_fetch_common(hv,keysv,key,keylen,HV_FETCH_ISSTORE,sv,
+ return hv_fetch_common(hv,keysv,key,klen,flags,HV_FETCH_ISSTORE,sv,
hash);
}
}
/* Welcome to hv_store... */
- if (!oentry) {
+ if (!xhv->xhv_array) {
/* Not sure if we can get here. I think the only case of oentry being
NULL is for %ENV with dynamic env fetch. But that should disappear
with magic in the previous code. */
Newz(503, xhv->xhv_array /* HvARRAY(hv) */,
PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
char);
- oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
}
+ oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
+
entry = new_HE();
/* share_hek_flags will do the free for us. This might be considered
bad API design. */
}
/*
-=for apidoc hv_store
+=for apidoc hv_scalar
-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
-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
-responsible for suitably incrementing the reference count of C<val> before
-the call, and decrementing it if the function returned NULL. Effectively
-a successful hv_store takes ownership of one reference to C<val>. This is
-usually what you want; a newly created SV has a reference count of one, so
-if all your code does is create SVs then store them in a hash, hv_store
-will own the only reference to the new SV, and your code doesn't need to do
-anything further to tidy up. hv_store is not implemented as a call to
-hv_store_ent, and does not create a temporary SV for the key, so if your
-key data is not already in SV form then use hv_store in preference to
-hv_store_ent.
-
-See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
-information on how to use this function on tied hashes.
-
-=cut
-*/
-
-SV**
-Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen_i32, SV *val, U32 hash)
-{
- HE *hek;
- STRLEN klen;
- int flags;
-
- if (klen_i32 < 0) {
- klen = -klen_i32;
- flags = HVhek_UTF8;
- } else {
- klen = klen_i32;
- flags = 0;
- }
- hek = hv_fetch_common (hv, NULL, key, klen, flags,
- (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, 0);
- return hek ? &HeVAL(hek) : NULL;
-}
-
-SV**
-Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val,
- register U32 hash, int flags)
-{
- HE *hek = hv_fetch_common (hv, NULL, key, klen, flags,
- (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash);
- return hek ? &HeVAL(hek) : NULL;
-}
-
-/*
-=for apidoc hv_store_ent
-
-Stores C<val> in a hash. The hash key is specified as C<key>. The C<hash>
-parameter is the precomputed hash value; if it is zero then Perl will
-compute it. The return value is the new hash entry so created. It 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 the
-contents of the return value can be accessed using the C<He?> macros
-described here. Note that the caller is responsible for suitably
-incrementing the reference count of C<val> before the call, and
-decrementing it if the function returned NULL. Effectively a successful
-hv_store_ent takes ownership of one reference to C<val>. This is
-usually what you want; a newly created SV has a reference count of one, so
-if all your code does is create SVs then store them in a hash, hv_store
-will own the only reference to the new SV, and your code doesn't need to do
-anything further to tidy up. Note that hv_store_ent only reads the C<key>;
-unlike C<val> it does not take ownership of it, so maintaining the correct
-reference count on C<key> is entirely the caller's responsibility. hv_store
-is not implemented as a call to hv_store_ent, and does not create a temporary
-SV for the key, so if your key data is not already in SV form then use
-hv_store in preference to hv_store_ent.
-
-See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
-information on how to use this function on tied hashes.
+Evaluates the hash in scalar context and returns the result. Handles magic when the hash is tied.
=cut
*/
-HE *
-Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, U32 hash)
+SV *
+Perl_hv_scalar(pTHX_ HV *hv)
{
- return hv_fetch_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISSTORE, val, hash);
+ MAGIC *mg;
+ SV *sv;
+
+ if ((SvRMAGICAL(hv) && (mg = mg_find((SV*)hv, PERL_MAGIC_tied)))) {
+ sv = magic_scalarpack(hv, mg);
+ return sv;
+ }
+
+ sv = sv_newmortal();
+ if (HvFILL((HV*)hv))
+ Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
+ (long)HvFILL(hv), (long)HvMAX(hv) + 1);
+ else
+ sv_setiv(sv, 0);
+
+ return sv;
}
/*
return hv_delete_common(hv, keysv, NULL, 0, 0, flags, hash);
}
-SV *
+STATIC SV *
S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
int k_flags, I32 d_flags, U32 hash)
{
return Nullsv;
if (keysv) {
+ if (k_flags & HVhek_FREEKEY)
+ Safefree(key);
key = SvPV(keysv, klen);
k_flags = 0;
is_utf8 = (SvUTF8(keysv) != 0);
}
return Nullsv; /* element cannot be deleted */
}
- }
#ifdef ENV_IS_CASELESS
- else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
- /* XXX This code isn't UTF8 clean. */
- keysv = sv_2mortal(newSVpvn(key,klen));
- key = strupr(SvPVX(keysv));
-
- if (k_flags & HVhek_FREEKEY) {
- Safefree(keysave);
+ else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
+ /* XXX This code isn't UTF8 clean. */
+ keysv = sv_2mortal(newSVpvn(key,klen));
+ if (k_flags & HVhek_FREEKEY) {
+ Safefree(key);
+ }
+ key = strupr(SvPVX(keysv));
+ is_utf8 = 0;
+ k_flags = 0;
+ hash = 0;
}
-
- is_utf8 = 0;
- k_flags = 0;
- hash = 0;
- }
#endif
+ }
}
}
xhv = (XPVHV*)SvANY(hv);
} else {
PERL_HASH(hash, key, klen);
}
- PERL_HASH(hash, key, klen);
}
masked_flags = (k_flags & HVhek_MASK);
/* if placeholder is here, it's already been deleted.... */
if (HeVAL(entry) == &PL_sv_placeholder)
{
- if (SvREADONLY(hv))
- return Nullsv; /* if still SvREADONLY, leave it deleted. */
-
- /* okay, really delete the placeholder. */
- *oentry = HeNEXT(entry);
- if (i && !*oentry)
- xhv->xhv_fill--; /* HvFILL(hv)-- */
- if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
- HvLAZYDEL_on(hv);
- else
- hv_free_ent(hv, entry);
- xhv->xhv_keys--; /* HvKEYS(hv)-- */
- if (xhv->xhv_keys == 0)
- HvHASKFLAGS_off(hv);
- xhv->xhv_placeholders--;
return Nullsv;
}
else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
* an error.
*/
if (SvREADONLY(hv)) {
+ SvREFCNT_dec(HeVAL(entry));
HeVAL(entry) = &PL_sv_placeholder;
/* We'll be saving this slot, so the number of allocated keys
* doesn't go down, but the number placeholders goes up */
return Nullsv;
}
-/*
-=for apidoc hv_exists
-
-Returns a boolean indicating whether the specified hash key exists. The
-C<klen> is the length of the key.
-
-=cut
-*/
-
-bool
-Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen_i32)
-{
- STRLEN klen;
- int flags;
-
- if (klen_i32 < 0) {
- klen = -klen_i32;
- flags = HVhek_UTF8;
- } else {
- klen = klen_i32;
- flags = 0;
- }
- return hv_fetch_common(hv, NULL, key, klen, flags, HV_FETCH_ISEXISTS, 0, 0)
- ? TRUE : FALSE;
-}
-
-/*
-=for apidoc hv_exists_ent
-
-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.
-
-=cut
-*/
-
-bool
-Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
-{
- return hv_fetch_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISEXISTS, 0, hash)
- ? TRUE : FALSE;
-}
-
STATIC void
S_hsplit(pTHX_ HV *hv)
{
+ /* Can't make this clear any placeholders first for non-restricted hashes,
+ as Storable rebuilds restricted hashes by putting in all the
+ placeholders (first) before turning on the readonly flag. Hence midway
+ through restoring the hash there are placeholders which need to remain
+ even though the hash isn't (currently) flagged as restricted. */
register XPVHV* xhv = (XPVHV*)SvANY(hv);
I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
register I32 newsize = oldsize * 2;
}
}
}
- return;
+ goto reset;
}
hfreeentries(hv);
HvHASKFLAGS_off(hv);
HvREHASH_off(hv);
+ reset:
+ HvEITER(hv) = NULL;
}
/*
void
Perl_hv_clear_placeholders(pTHX_ HV *hv)
{
- I32 items;
- items = (I32)HvPLACEHOLDERS(hv);
- if (items) {
- HE *entry;
- I32 riter = HvRITER(hv);
- HE *eiter = HvEITER(hv);
- hv_iterinit(hv);
- /* This may look suboptimal with the items *after* the iternext, but
- it's quite deliberate. We only get here with items==0 if we've
- just deleted the last placeholder in the hash. If we've just done
- that then it means that the hash is in lazy delete mode, and the
- HE is now only referenced in our iterator. If we just quit the loop
- and discarded our iterator then the HE leaks. So we do the && the
- other way to ensure iternext is called just one more time, which
- has the side effect of triggering the lazy delete. */
- while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
- && items) {
- SV *val = hv_iterval(hv, entry);
-
- if (val == &PL_sv_placeholder) {
-
- /* It seems that I have to go back in the front of the hash
- API to delete a hash, even though I have a HE structure
- pointing to the very entry I want to delete, and could hold
- onto the previous HE that points to it. And it's easier to
- go in with SVs as I can then specify the precomputed hash,
- and don't have fun and games with utf8 keys. */
- SV *key = hv_iterkeysv(entry);
-
- hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
- items--;
- }
- }
- HvRITER(hv) = riter;
- HvEITER(hv) = eiter;
- }
+ I32 items = (I32)HvPLACEHOLDERS(hv);
+ I32 i = HvMAX(hv);
+
+ if (items == 0)
+ return;
+
+ do {
+ /* Loop down the linked list heads */
+ int first = 1;
+ HE **oentry = &(HvARRAY(hv))[i];
+ HE *entry = *oentry;
+
+ if (!entry)
+ continue;
+
+ for (; entry; first=0, oentry = &HeNEXT(entry), entry = *oentry) {
+ if (HeVAL(entry) == &PL_sv_placeholder) {
+ *oentry = HeNEXT(entry);
+ if (first && !*oentry)
+ HvFILL(hv)--; /* This linked list is now empty. */
+ if (HvEITER(hv))
+ HvLAZYDEL_on(hv);
+ else
+ hv_free_ent(hv, entry);
+
+ if (--items == 0) {
+ /* Finished. */
+ HvTOTALKEYS(hv) -= HvPLACEHOLDERS(hv);
+ if (HvKEYS(hv) == 0)
+ HvHASKFLAGS_off(hv);
+ HvPLACEHOLDERS(hv) = 0;
+ return;
+ }
+ }
+ }
+ } while (--i >= 0);
+ /* You can't get here, hence assertion should always fail. */
+ assert (items == 0);
+ assert (0);
}
STATIC void
}
if (!found) {
entry = new_HE();
- HeKEY_hek(entry) = save_hek_flags(str, len, hash, flags);
+ HeKEY_hek(entry) = save_hek_flags(str, len, hash, flags_masked);
HeVAL(entry) = Nullsv;
HeNEXT(entry) = *oentry;
*oentry = entry;