S_more_he(pTHX)
{
dVAR;
- HE* he = (HE*) Perl_get_arena(aTHX_ PERL_ARENA_SIZE, HE_SVSLOT);
- HE * const heend = &he[PERL_ARENA_SIZE / sizeof(HE) - 1];
+ /* 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) {
char *k;
register HEK *hek;
+ PERL_ARGS_ASSERT_SAVE_HEK_FLAGS;
+
Newx(k, HEK_BASESIZE + len + 2, char);
hek = (HEK*)k;
Copy(str, HEK_KEY(hek), len, char);
{
HEK *shared = (HEK*)ptr_table_fetch(PL_ptr_table, source);
+ PERL_ARGS_ASSERT_HEK_DUP;
PERL_UNUSED_ARG(param);
if (shared) {
{
HE *ret;
+ PERL_ARGS_ASSERT_HE_DUP;
+
if (!e)
return NULL;
/* look for it in the table first */
const char *msg)
{
SV * const sv = sv_newmortal();
+
+ PERL_ARGS_ASSERT_HV_NOTALLOWED;
+
if (!(flags & HVhek_FREEKEY)) {
sv_setpvn(sv, key, klen);
}
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, hash);
- return hek ? &HeVAL(hek) : NULL;
-}
-
-/* XXX This looks like an ideal candidate to inline */
-SV**
-Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val,
- register U32 hash, int flags)
-{
- HE * const 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>
See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
information on how to use this function on tied hashes.
-=cut
-*/
-
-/* XXX This looks like an ideal candidate to inline */
-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
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 = hv_fetch_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
*/
-/* XXX This looks like an ideal candidate to inline */
-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 */
/*
=cut
*/
-HE *
-Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
+/* 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)
{
- return hv_fetch_common(hv, keysv, NULL, 0, 0,
- (lval ? HV_FETCH_LVALUE : 0), NULL, hash);
+ STRLEN klen;
+ int flags;
+
+ PERL_ARGS_ASSERT_HV_COMMON_KEY_LEN;
+
+ 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);
}
-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)
+void *
+Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
+ int flags, int action, SV *val, register U32 hash)
{
dVAR;
XPVHV* xhv;
SV *sv;
bool is_utf8;
int masked_flags;
+ const int return_svp = action & HV_FETCH_JUST_SV;
if (!hv)
return NULL;
+ if (SvTYPE(hv) == SVTYPEMASK)
+ return NULL;
- if (keysv) {
- if (SvSMAGICAL(hv) && SvGMAGICAL(hv)
- && !(action & HV_DISABLE_UVAR_XKEY)) {
- keysv = hv_magic_uvar_xkey(hv, keysv, 0, 0, 0, action);
- /* If a fetch-as-store fails on the fetch, then the action is to
- recurse once into "hv_store". If we didn't do this, then that
- recursive call would call the key conversion routine again.
- However, as we replace the original key with the converted
- key, this would result in a double conversion, which would show
- up as a bug if the conversion routine is not idempotent. */
+ assert(SvTYPE(hv) == SVt_PVHV);
+
+ if (SvSMAGICAL(hv) && SvGMAGICAL(hv) && !(action & HV_DISABLE_UVAR_XKEY)) {
+ MAGIC* mg;
+ if ((mg = mg_find((SV*)hv, PERL_MAGIC_uvar))) {
+ struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
+ if (uf->uf_set == NULL) {
+ SV* obj = mg->mg_obj;
+
+ if (!keysv) {
+ keysv = newSVpvn_flags(key, klen, SVs_TEMP |
+ ((flags & HVhek_UTF8)
+ ? SVf_UTF8 : 0));
+ }
+
+ mg->mg_obj = keysv; /* pass key */
+ uf->uf_index = action; /* pass action */
+ magic_getuvar((SV*)hv, mg);
+ keysv = mg->mg_obj; /* may have changed */
+ mg->mg_obj = obj;
+
+ /* If the key may have changed, then we need to invalidate
+ any passed-in computed hash value. */
+ hash = 0;
+ }
}
+ }
+ if (keysv) {
if (flags & HVhek_FREEKEY)
Safefree(key);
key = SvPV_const(keysv, klen);
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);
+ }
+
xhv = (XPVHV*)SvANY(hv);
if (SvMAGICAL(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)) {
const char * const 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, NULL, nkey, klen,
- HVhek_FREEKEY, /* free nkey */
- 0 /* non-LVAL fetch */
- | HV_DISABLE_UVAR_XKEY,
- NULL /* no value */,
- 0 /* compute hash */);
- if (!entry && (action & HV_FETCH_LVALUE)) {
+ void *result = hv_common(hv, NULL, nkey, klen,
+ HVhek_FREEKEY, /* free nkey */
+ 0 /* non-LVAL fetch */
+ | HV_DISABLE_UVAR_XKEY
+ | return_svp,
+ NULL /* no value */,
+ 0 /* compute hash */);
+ if (!result && (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
- | HV_DISABLE_UVAR_XKEY,
- newSV(0), hash);
+ result = hv_common(hv, keysv, key, klen, flags,
+ HV_FETCH_ISSTORE
+ | HV_DISABLE_UVAR_XKEY
+ | return_svp,
+ newSV(0), hash);
} else {
if (flags & HVhek_FREEKEY)
Safefree(key);
}
- return entry;
+ return result;
}
}
#endif
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 */
if (env) {
sv = newSVpvn(env,len);
SvTAINTED_on(sv);
- return hv_fetch_common(hv, keysv, key, klen, flags,
- HV_FETCH_ISSTORE|HV_DISABLE_UVAR_XKEY, sv,
- hash);
+ return hv_common(hv, keysv, key, klen, flags,
+ 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);
which in turn might do some tied magic. So we need to make that
magic check happen. */
/* gonna assign to this, so it better be there */
- return hv_fetch_common(hv, keysv, key, klen, flags,
- HV_FETCH_ISSTORE|HV_DISABLE_UVAR_XKEY, val,
- hash);
+ /* If a fetch-as-store fails on the fetch, then the action is to
+ recurse once into "hv_store". If we didn't do this, then that
+ recursive call would call the key conversion routine again.
+ However, as we replace the original key with the converted
+ 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|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
S_hv_magic_check(HV *hv, bool *needs_copy, bool *needs_store)
{
const MAGIC *mg = SvMAGIC(hv);
+
+ PERL_ARGS_ASSERT_HV_MAGIC_CHECK;
+
*needs_copy = FALSE;
*needs_store = TRUE;
while (mg) {
{
SV *sv;
+ PERL_ARGS_ASSERT_HV_SCALAR;
+
if (SvRMAGICAL(hv)) {
MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_tied);
if (mg)
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 hv_delete_common(hv, NULL, key, klen, k_flags, flags, 0);
-}
-
-/*
=for apidoc hv_delete_ent
Deletes a key/value pair in the hash. The value SV is removed from the
=cut
*/
-/* XXX This looks like an ideal candidate to inline */
-SV *
-Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
-{
- return hv_delete_common(hv, keysv, NULL, 0, 0, flags, hash);
-}
-
STATIC SV *
S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
int k_flags, I32 d_flags, U32 hash)
register HE *entry;
register HE **oentry;
HE *const *first_entry;
- bool is_utf8;
+ bool is_utf8 = (k_flags & HVhek_UTF8) ? TRUE : FALSE;
int masked_flags;
- if (!hv)
- return NULL;
-
- if (SvSMAGICAL(hv) && SvGMAGICAL(hv)
- && !(d_flags & HV_DISABLE_UVAR_XKEY))
- keysv = hv_magic_uvar_xkey(hv, keysv, key, klen, k_flags, HV_DELETE);
- if (keysv) {
- if (k_flags & HVhek_FREEKEY)
- Safefree(key);
- key = SvPV_const(keysv, klen);
- k_flags = 0;
- is_utf8 = (SvUTF8(keysv) != 0);
- } else {
- is_utf8 = ((k_flags & HVhek_UTF8) ? TRUE : FALSE);
- }
-
if (SvRMAGICAL(hv)) {
bool needs_copy;
bool needs_store;
if (needs_copy) {
SV *sv;
- entry = hv_fetch_common(hv, keysv, key, klen,
- k_flags & ~HVhek_FREEKEY,
- HV_FETCH_LVALUE|HV_DISABLE_UVAR_XKEY,
- NULL, hash);
+ entry = (HE *) hv_common(hv, keysv, key, klen,
+ k_flags & ~HVhek_FREEKEY,
+ HV_FETCH_LVALUE|HV_DISABLE_UVAR_XKEY,
+ NULL, hash);
sv = entry ? HeVAL(entry) : NULL;
if (sv) {
if (SvMAGICAL(sv)) {
#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);
}
int longest_chain = 0;
int was_shared;
+ PERL_ARGS_ASSERT_HSPLIT;
+
/*PerlIO_printf(PerlIO_stderr(), "hsplit called for %p which had %d\n",
(void*)hv, (int) oldsize);*/
register HE *entry;
register HE **oentry;
+ PERL_ARGS_ASSERT_HV_KSPLIT;
+
newsize = (I32) newmax; /* possible truncation here */
if (newsize != newmax || newmax <= oldsize)
return;
}
}
-/*
-=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);
dVAR;
SV *val;
+ PERL_ARGS_ASSERT_HV_FREE_ENT;
+
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) {
Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
{
dVAR;
+
+ PERL_ARGS_ASSERT_HV_DELAYFREE_ENT;
+
if (!entry)
return;
/* SvREFCNT_inc to counter the SvREFCNT_dec in hv_free_ent */
dVAR;
const U32 items = (U32)HvPLACEHOLDERS_get(hv);
+ PERL_ARGS_ASSERT_HV_CLEAR_PLACEHOLDERS;
+
if (items)
clear_placeholders(hv, items);
}
dVAR;
I32 i;
+ PERL_ARGS_ASSERT_CLEAR_PLACEHOLDERS;
+
if (items == 0)
return;
HEK *name;
int attempts = 100;
+ PERL_ARGS_ASSERT_HFREEENTRIES;
+
if (!orig_array)
return;
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;
struct xpvhv_aux *iter;
char *array;
+ PERL_ARGS_ASSERT_HV_AUXINIT;
+
if (!HvARRAY(hv)) {
Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
+ sizeof(struct xpvhv_aux), char);
I32
Perl_hv_iterinit(pTHX_ HV *hv)
{
+ PERL_ARGS_ASSERT_HV_ITERINIT;
+
+ /* FIXME: Are we not NULL, or do we croak? Place bets now! */
+
if (!hv)
Perl_croak(aTHX_ "Bad hash");
Perl_hv_riter_p(pTHX_ HV *hv) {
struct xpvhv_aux *iter;
+ PERL_ARGS_ASSERT_HV_RITER_P;
+
if (!hv)
Perl_croak(aTHX_ "Bad hash");
Perl_hv_eiter_p(pTHX_ HV *hv) {
struct xpvhv_aux *iter;
+ PERL_ARGS_ASSERT_HV_EITER_P;
+
if (!hv)
Perl_croak(aTHX_ "Bad hash");
Perl_hv_riter_set(pTHX_ HV *hv, I32 riter) {
struct xpvhv_aux *iter;
+ PERL_ARGS_ASSERT_HV_RITER_SET;
+
if (!hv)
Perl_croak(aTHX_ "Bad hash");
Perl_hv_eiter_set(pTHX_ HV *hv, HE *eiter) {
struct xpvhv_aux *iter;
+ PERL_ARGS_ASSERT_HV_EITER_SET;
+
if (!hv)
Perl_croak(aTHX_ "Bad hash");
struct xpvhv_aux *iter;
U32 hash;
+ PERL_ARGS_ASSERT_HV_NAME_SET;
PERL_UNUSED_ARG(flags);
if (len > I32_MAX)
AV **
Perl_hv_backreferences_p(pTHX_ HV *hv) {
struct xpvhv_aux * const iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
+
+ PERL_ARGS_ASSERT_HV_BACKREFERENCES_P;
PERL_UNUSED_CONTEXT;
+
return &(iter->xhv_backreferences);
}
Perl_hv_kill_backrefs(pTHX_ HV *hv) {
AV *av;
+ PERL_ARGS_ASSERT_HV_KILL_BACKREFS;
+
if (!SvOOK(hv))
return;
MAGIC* mg;
struct xpvhv_aux *iter;
+ PERL_ARGS_ASSERT_HV_ITERNEXT_FLAGS;
+
if (!hv)
Perl_croak(aTHX_ "Bad hash");
char *
Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
{
+ PERL_ARGS_ASSERT_HV_ITERKEY;
+
if (HeKLEN(entry) == HEf_SVKEY) {
STRLEN len;
char * const p = SvPV(HeKEY_sv(entry), len);
SV *
Perl_hv_iterkeysv(pTHX_ register HE *entry)
{
+ PERL_ARGS_ASSERT_HV_ITERKEYSV;
+
return sv_2mortal(newSVhek(HeKEY_hek(entry)));
}
SV *
Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
{
+ PERL_ARGS_ASSERT_HV_ITERVAL;
+
if (SvRMAGICAL(hv)) {
if (mg_find((SV*)hv, PERL_MAGIC_tied)) {
SV* const sv = sv_newmortal();
{
HE * const he = hv_iternext_flags(hv, 0);
+ PERL_ARGS_ASSERT_HV_ITERNEXTSV;
+
if (!he)
return NULL;
*key = hv_iterkey(he, retlen);
int flags = 0;
const char * const save = str;
+ PERL_ARGS_ASSERT_SHARE_HEK;
+
if (len < 0) {
STRLEN tmplen = -len;
is_utf8 = TRUE;
register 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);
+
+ PERL_ARGS_ASSERT_SHARE_HEK_FLAGS;
/* what follows is the moral equivalent of:
Can't rehash the shared string table, so not sure if it's worth
counting the number of entries in the linked list
*/
- register XPVHV * const xhv = (XPVHV*)SvANY(PL_strtab);
+
/* assert(xhv_array != 0) */
LOCK_STRTAB_MUTEX;
entry = (HvARRAY(PL_strtab))[hindex];
return HeKEY_hek(entry);
}
-STATIC SV *
-S_hv_magic_uvar_xkey(pTHX_ HV* hv, SV* keysv, const char *const key,
- const STRLEN klen, const int k_flags, int action)
-{
- MAGIC* mg;
- if ((mg = mg_find((SV*)hv, PERL_MAGIC_uvar))) {
- struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
- if (uf->uf_set == NULL) {
- SV* obj = mg->mg_obj;
-
- if (!keysv) {
- keysv = sv_2mortal(newSVpvn(key, klen));
- if (k_flags & HVhek_UTF8)
- SvUTF8_on(keysv);
- }
-
- mg->mg_obj = keysv; /* pass key */
- uf->uf_index = action; /* pass action */
- magic_getuvar((SV*)hv, mg);
- keysv = mg->mg_obj; /* may have changed */
- mg->mg_obj = obj;
- }
- }
- return keysv;
-}
-
I32 *
Perl_hv_placeholders_p(pTHX_ HV *hv)
{
dVAR;
MAGIC *mg = mg_find((SV*)hv, PERL_MAGIC_rhash);
+ PERL_ARGS_ASSERT_HV_PLACEHOLDERS_P;
+
if (!mg) {
mg = sv_magicext((SV*)hv, 0, PERL_MAGIC_rhash, 0, 0, 0);
dVAR;
MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_rhash);
+ PERL_ARGS_ASSERT_HV_PLACEHOLDERS_GET;
+
return mg ? mg->mg_len : 0;
}
dVAR;
MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_rhash);
+ PERL_ARGS_ASSERT_HV_PLACEHOLDERS_SET;
+
if (mg) {
mg->mg_len = ph;
} else if (ph) {
{
dVAR;
SV *value;
+
+ PERL_ARGS_ASSERT_REFCOUNTED_HE_VALUE;
+
switch(he->refcounted_he_data[0] & HVrhek_typemask) {
case HVrhek_undef:
value = newSV(0);
}
}
+const char *
+Perl_fetch_cop_label(pTHX_ struct refcounted_he *const chain, STRLEN *len,
+ U32 *flags) {
+ if (!chain)
+ return NULL;
+#ifdef USE_ITHREADS
+ if (chain->refcounted_he_keylen != 1)
+ return NULL;
+ if (*REF_HE_KEY(chain) != ':')
+ return NULL;
+#else
+ if ((STRLEN)HEK_LEN(chain->refcounted_he_hek) != 1)
+ return NULL;
+ if (*HEK_KEY(chain->refcounted_he_hek) != ':')
+ return NULL;
+#endif
+ if (len)
+ *len = chain->refcounted_he_val.refcounted_he_u_len;
+ if (flags) {
+ *flags = ((chain->refcounted_he_data[0] & HVrhek_typemask)
+ == HVrhek_PV_UTF8) ? SVf_UTF8 : 0;
+ }
+ return chain->refcounted_he_data + 1;
+}
+
/*
=for apidoc hv_assert
const I32 riter = HvRITER_get(hv);
HE *eiter = HvEITER_get(hv);
+ PERL_ARGS_ASSERT_HV_ASSERT;
+
(void)hv_iterinit(hv);
while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
https://perl5.git.perl.org / perl5.git / blobdiff