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 = (HE *) hv_common(hv, NULL, key, klen, flags,
- (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash);
- return hek ? &HeVAL(hek) : NULL;
-}
-
-/* Tricky to inlike this because it needs a temporary variable */
-SV**
-Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val,
- register U32 hash, int flags)
-{
- HE * const hek = (HE *) hv_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>
See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
information on how to use this function on tied hashes.
-=cut
-*/
-
-/*
=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_common(hv, NULL, key, klen, flags, HV_FETCH_ISEXISTS, 0, 0)
- ? TRUE : FALSE;
-}
-
-/*
=for apidoc hv_fetch
Returns the SV which corresponds to the specified key in the hash. The
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_fetch(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 lval)
-{
- HE *hek;
- STRLEN klen;
- int flags;
-
- if (klen_i32 < 0) {
- klen = -klen_i32;
- flags = HVhek_UTF8;
- } else {
- klen = klen_i32;
- flags = 0;
- }
- hek = (HE *) hv_common(hv, NULL, key, klen, flags,
- lval ? (HV_FETCH_JUST_SV | HV_FETCH_LVALUE)
- : HV_FETCH_JUST_SV, NULL, 0);
- return hek ? &HeVAL(hek) : NULL;
-}
-
-/*
=for apidoc hv_exists_ent
Returns a boolean indicating whether the specified hash key exists. C<hash>
=cut
*/
+/* Common code for hv_delete()/hv_exists()/hv_fetch()/hv_store() */
+void *
+Perl_hv_common_key_len(pTHX_ HV *hv, const char *key, I32 klen_i32,
+ const int action, SV *val, const U32 hash)
+{
+ STRLEN klen;
+ int flags;
+
+ if (klen_i32 < 0) {
+ klen = -klen_i32;
+ flags = HVhek_UTF8;
+ } else {
+ klen = klen_i32;
+ flags = 0;
+ }
+ return hv_common(hv, NULL, key, klen, flags, action, val, hash);
+}
+
void *
Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
int flags, int action, SV *val, register U32 hash)
SV *sv;
bool is_utf8;
int masked_flags;
+ const int return_svp = action & HV_FETCH_JUST_SV;
if (!hv)
return NULL;
SV* obj = mg->mg_obj;
if (!keysv) {
- keysv = sv_2mortal(newSVpvn(key, klen));
- if (flags & HVhek_UTF8)
- SvUTF8_on(keysv);
+ keysv = newSVpvn_flags(key, klen, SVs_TEMP |
+ ((flags & HVhek_UTF8)
+ ? SVf_UTF8 : 0));
}
mg->mg_obj = keysv; /* pass key */
}
if (action & HV_DELETE) {
- return (HE *) hv_delete_common(hv, keysv, key, klen,
- flags | (is_utf8 ? HVhek_UTF8 : 0),
- action, hash);
+ return (void *) hv_delete_common(hv, keysv, key, klen,
+ flags | (is_utf8 ? HVhek_UTF8 : 0),
+ action, hash);
}
xhv = (XPVHV*)SvANY(hv);
if (SvRMAGICAL(hv) && !(action & (HV_FETCH_ISSTORE|HV_FETCH_ISEXISTS))) {
if ( mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv))
{
- /* XXX should be able to skimp on the HE/HEK here when
+ /* FIXME should be able to skimp on the HE/HEK here when
HV_FETCH_JUST_SV is true. */
if (!keysv) {
- keysv = newSVpvn(key, klen);
- if (is_utf8) {
- SvUTF8_on(keysv);
- }
- } else {
+ keysv = newSVpvn_utf8(key, klen, is_utf8);
+ } else {
keysv = newSVsv(keysv);
}
sv = sv_newmortal();
if (flags & HVhek_FREEKEY)
Safefree(key);
- return entry;
+ if (return_svp) {
+ return entry ? (void *) &HeVAL(entry) : NULL;
+ }
+ return (void *) entry;
}
#ifdef ENV_IS_CASELESS
else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
void *result = hv_common(hv, NULL, nkey, klen,
HVhek_FREEKEY, /* free nkey */
0 /* non-LVAL fetch */
- | HV_DISABLE_UVAR_XKEY,
+ | HV_DISABLE_UVAR_XKEY
+ | return_svp,
NULL /* no value */,
0 /* compute hash */);
- if (!entry && (action & HV_FETCH_LVALUE)) {
+ if (!result && (action & HV_FETCH_LVALUE)) {
/* This call will free key if necessary.
Do it this way to encourage compiler to tail
call optimise. */
result = hv_common(hv, keysv, key, klen, flags,
HV_FETCH_ISSTORE
- | HV_DISABLE_UVAR_XKEY,
+ | HV_DISABLE_UVAR_XKEY
+ | return_svp,
newSV(0), hash);
} else {
if (flags & HVhek_FREEKEY)
if (keysv || is_utf8) {
if (!keysv) {
- keysv = newSVpvn(key, klen);
- SvUTF8_on(keysv);
+ keysv = newSVpvn_utf8(key, klen, TRUE);
} else {
keysv = newSVsv(keysv);
}
/* This cast somewhat evil, but I'm merely using NULL/
not NULL to return the boolean exists.
And I know hv is not NULL. */
- return SvTRUE(svret) ? (HE *)hv : NULL;
+ return SvTRUE(svret) ? (void *)hv : NULL;
}
#ifdef ENV_IS_CASELESS
else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
const bool save_taint = PL_tainted;
if (keysv || is_utf8) {
if (!keysv) {
- keysv = newSVpvn(key, klen);
- SvUTF8_on(keysv);
+ keysv = newSVpvn_utf8(key, klen, TRUE);
}
if (PL_tainting)
PL_tainted = SvTAINTED(keysv);
if (flags & HVhek_FREEKEY)
Safefree(key);
- return 0;
+ return NULL;
}
}
}
if (flags & HVhek_FREEKEY)
Safefree(key);
+ if (return_svp) {
+ return entry ? (void *) &HeVAL(entry) : NULL;
+ }
return entry;
}
#ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
sv = newSVpvn(env,len);
SvTAINTED_on(sv);
return hv_common(hv, keysv, key, klen, flags,
- HV_FETCH_ISSTORE|HV_DISABLE_UVAR_XKEY, sv, hash);
+ HV_FETCH_ISSTORE|HV_DISABLE_UVAR_XKEY|return_svp,
+ sv, hash);
}
}
#endif
/* Not doing some form of store, so return failure. */
if (flags & HVhek_FREEKEY)
Safefree(key);
- return 0;
+ return NULL;
}
if (action & HV_FETCH_LVALUE) {
val = newSV(0);
key, this would result in a double conversion, which would show
up as a bug if the conversion routine is not idempotent. */
return hv_common(hv, keysv, key, klen, flags,
- HV_FETCH_ISSTORE|HV_DISABLE_UVAR_XKEY, val, hash);
+ HV_FETCH_ISSTORE|HV_DISABLE_UVAR_XKEY|return_svp,
+ val, hash);
/* XXX Surely that could leak if the fetch-was-store fails?
Just like the hv_fetch. */
}
}
}
- return entry;
+ if (return_svp) {
+ return entry ? (void *) &HeVAL(entry) : NULL;
+ }
+ return (void *) entry;
}
STATIC void
The C<flags> value will normally be zero; if set to G_DISCARD then NULL
will be returned.
-=cut
-*/
-
-SV *
-Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 flags)
-{
- STRLEN klen;
- int k_flags;
-
- if (klen_i32 < 0) {
- klen = -klen_i32;
- k_flags = HVhek_UTF8;
- } else {
- klen = klen_i32;
- k_flags = 0;
- }
- return (SV *) hv_common(hv, NULL, key, klen, k_flags, flags | HV_DELETE,
- NULL, 0);
-}
-
-/*
=for apidoc hv_delete_ent
Deletes a key/value pair in the hash. The value SV is removed from the
#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));
+ keysv = newSVpvn_flags(key, klen, SVs_TEMP);
if (k_flags & HVhek_FREEKEY) {
Safefree(key);
}
}
}
-/*
-=for apidoc newHV
-
-Creates a new HV. The reference count is set to 1.
-
-=cut
-*/
-
-HV *
-Perl_newHV(pTHX)
-{
- register XPVHV* xhv;
- HV * const hv = (HV*)newSV_type(SVt_PVHV);
- xhv = (XPVHV*)SvANY(hv);
- assert(!SvOK(hv));
-#ifndef NODEFAULT_SHAREKEYS
- HvSHAREKEYS_on(hv); /* key-sharing on by default */
-#endif
-
- xhv->xhv_max = 7; /* HvMAX(hv) = 7 (start with 8 buckets) */
- xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
- return hv;
-}
-
HV *
Perl_newHVhv(pTHX_ HV *ohv)
{
hv_iterinit(ohv);
while ((entry = hv_iternext_flags(ohv, 0))) {
- hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
- newSVsv(HeVAL(entry)), HeHASH(entry),
- HeKFLAGS(entry));
+ (void)hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
+ newSVsv(HeVAL(entry)), HeHASH(entry),
+ HeKFLAGS(entry));
}
HvRITER_set(ohv, riter);
HvEITER_set(ohv, eiter);
SV *const sv = newSVsv(HeVAL(entry));
sv_magic(sv, NULL, PERL_MAGIC_hintselem,
(char *)newSVhek (HeKEY_hek(entry)), HEf_SVKEY);
- hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
- sv, HeHASH(entry), HeKFLAGS(entry));
+ (void)hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
+ sv, HeHASH(entry), HeKFLAGS(entry));
}
HvRITER_set(ohv, riter);
HvEITER_set(ohv, eiter);
if (!entry)
return;
val = HeVAL(entry);
- if (val && isGV(val) && GvCVu(val) && HvNAME_get(hv))
+ if (val && isGV(val) && isGV_with_GP(val) && GvCVu(val) && HvNAME_get(hv))
mro_method_changed_in(hv); /* deletion of method from stash */
SvREFCNT_dec(val);
if (HeKLEN(entry) == HEf_SVKEY) {
hfreeentries(hv);
if (name) {
- if(PL_stashcache)
- hv_delete(PL_stashcache, name, HvNAMELEN_get(hv), G_DISCARD);
+ if (PL_stashcache)
+ (void)hv_delete(PL_stashcache, name, HvNAMELEN_get(hv), G_DISCARD);
hv_name_set(hv, NULL, 0, 0);
}
SvFLAGS(hv) &= ~SVf_OOK;
projects / p5sagit/p5-mst-13.2.git / blobdiff