/* hv.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
HE* he;
HE* heend;
- he = (HE*) Perl_get_arena(aTHX_ PERL_ARENA_SIZE);
+ he = (HE*) Perl_get_arena(aTHX_ PERL_ARENA_SIZE, HE_SVSLOT);
heend = &he[PERL_ARENA_SIZE / sizeof(HE) - 1];
PL_body_roots[HE_SVSLOT] = he;
HE* he;
void ** const root = &PL_body_roots[HE_SVSLOT];
- LOCK_SV_MUTEX;
if (!*root)
S_more_he(aTHX);
- he = *root;
+ he = (HE*) *root;
assert(he);
*root = HeNEXT(he);
- UNLOCK_SV_MUTEX;
return he;
}
#define new_HE() new_he()
#define del_HE(p) \
STMT_START { \
- LOCK_SV_MUTEX; \
HeNEXT(p) = (HE*)(PL_body_roots[HE_SVSLOT]); \
PL_body_roots[HE_SVSLOT] = p; \
- UNLOCK_SV_MUTEX; \
} STMT_END
if (flags & HVhek_UTF8) {
SvUTF8_on(sv);
}
- Perl_croak(aTHX_ msg, sv);
+ Perl_croak(aTHX_ msg, SVfARG(sv));
}
/* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
return NULL;
if (keysv) {
+ if (SvSMAGICAL(hv) && SvGMAGICAL(hv))
+ keysv = hv_magic_uvar_xkey(hv, keysv, action);
if (flags & HVhek_FREEKEY)
Safefree(key);
key = SvPV_const(keysv, klen);
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)) {
- sv = sv_newmortal();
-
+ if ( mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv))
+ {
/* XXX 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) {
} else {
keysv = newSVsv(keysv);
}
- mg_copy((SV*)hv, sv, (char *)keysv, HEf_SVKEY);
+ sv = sv_newmortal();
+ mg_copy((SV*)hv, sv, (char *)keysv, HEf_SVKEY);
/* grab a fake HE/HEK pair from the pool or make a new one */
entry = PL_hv_fetch_ent_mh;
return NULL;
if (keysv) {
+ if (SvSMAGICAL(hv) && SvGMAGICAL(hv))
+ keysv = hv_magic_uvar_xkey(hv, keysv, -1);
if (k_flags & HVhek_FREEKEY)
Safefree(key);
key = SvPV_const(keysv, klen);
int was_shared;
/*PerlIO_printf(PerlIO_stderr(), "hsplit called for %p which had %d\n",
- hv, (int) oldsize);*/
+ (void*)hv, (int) oldsize);*/
if (HvPLACEHOLDERS_get(hv) && !SvREADONLY(hv)) {
/* Can make this clear any placeholders first for non-restricted hashes,
}
/* Awooga. Awooga. Pathological data. */
- /*PerlIO_printf(PerlIO_stderr(), "%p %d of %d with %d/%d buckets\n", hv,
+ /*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;
Perl_newHV(pTHX)
{
register XPVHV* xhv;
- HV * const hv = (HV*)newSV(0);
-
- sv_upgrade((SV *)hv, SVt_PVHV);
+ HV * const hv = (HV*)newSV_type(SVt_PVHV);
xhv = (XPVHV*)SvANY(hv);
- SvPOK_off(hv);
- SvNOK_off(hv);
+ assert(!SvOK(hv));
#ifndef NODEFAULT_SHAREKEYS
HvSHAREKEYS_on(hv); /* key-sharing on by default */
#endif
S_hfreeentries(pTHX_ HV *hv)
{
/* This is the array that we're going to restore */
- HE **orig_array;
+ HE **const orig_array = HvARRAY(hv);
HEK *name;
int attempts = 100;
- if (!HvARRAY(hv))
+ if (!orig_array)
return;
if (SvOOK(hv)) {
name = NULL;
}
- orig_array = HvARRAY(hv);
/* 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
if (!hv)
Perl_croak(aTHX_ "Bad hash");
+
xhv = (XPVHV*)SvANY(hv);
if (!SvOOK(hv)) {
iter = HvAUX(hv);
oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
-
- if ((mg = SvTIED_mg((SV*)hv, PERL_MAGIC_tied))) {
- SV * const key = sv_newmortal();
- if (entry) {
- sv_setsv(key, HeSVKEY_force(entry));
- SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
- }
- else {
- char *k;
- HEK *hek;
-
- /* one HE per MAGICAL hash */
- iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
- Zero(entry, 1, HE);
- Newxz(k, HEK_BASESIZE + sizeof(SV*), char);
- hek = (HEK*)k;
- HeKEY_hek(entry) = hek;
- HeKLEN(entry) = HEf_SVKEY;
- }
- magic_nextpack((SV*) hv,mg,key);
- if (SvOK(key)) {
- /* force key to stay around until next time */
- HeSVKEY_set(entry, SvREFCNT_inc_simple_NN(key));
- return entry; /* beware, hent_val is not set */
- }
- if (HeVAL(entry))
- SvREFCNT_dec(HeVAL(entry));
- Safefree(HeKEY_hek(entry));
- del_HE(entry);
- iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
- return NULL;
+ if (SvMAGICAL(hv) && SvRMAGICAL(hv)) {
+ if ( ( mg = mg_find((SV*)hv, PERL_MAGIC_tied) ) ) {
+ SV * const key = sv_newmortal();
+ if (entry) {
+ sv_setsv(key, HeSVKEY_force(entry));
+ SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
+ }
+ else {
+ char *k;
+ HEK *hek;
+
+ /* one HE per MAGICAL hash */
+ iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
+ Zero(entry, 1, HE);
+ Newxz(k, HEK_BASESIZE + sizeof(SV*), char);
+ hek = (HEK*)k;
+ HeKEY_hek(entry) = hek;
+ HeKLEN(entry) = HEf_SVKEY;
+ }
+ magic_nextpack((SV*) hv,mg,key);
+ if (SvOK(key)) {
+ /* force key to stay around until next time */
+ HeSVKEY_set(entry, SvREFCNT_inc_simple_NN(key));
+ return entry; /* beware, hent_val is not set */
+ }
+ if (HeVAL(entry))
+ SvREFCNT_dec(HeVAL(entry));
+ Safefree(HeKEY_hek(entry));
+ del_HE(entry);
+ iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
+ return NULL;
+ }
}
#if defined(DYNAMIC_ENV_FETCH) && !defined(__riscos__) /* set up %ENV for iteration */
if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
}
/*if (HvREHASH(hv) && entry && !HeKREHASH(entry))
- PerlIO_printf(PerlIO_stderr(), "Awooga %p %p\n", hv, entry);*/
+ PerlIO_printf(PerlIO_stderr(), "Awooga %p %p\n", (void*)hv, (void*)entry);*/
iter->xhv_eiter = entry; /* HvEITER(hv) = entry */
return entry;
void
Perl_unshare_hek(pTHX_ HEK *hek)
{
+ assert(hek);
unshare_hek_or_pvn(hek, NULL, 0, 0);
}
return HeKEY_hek(entry);
}
+STATIC SV *
+S_hv_magic_uvar_xkey(pTHX_ HV* hv, SV* keysv, 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;
+ 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)
{
/* else we don't need to add magic to record 0 placeholders. */
}
-SV *
+STATIC SV *
S_refcounted_he_value(pTHX_ const struct refcounted_he *he)
{
+ dVAR;
SV *value;
switch(he->refcounted_he_data[0] & HVrhek_typemask) {
case HVrhek_undef:
case HVrhek_PV:
/* Create a string SV that directly points to the bytes in our
structure. */
- value = newSV(0);
- sv_upgrade(value, SVt_PV);
+ value = newSV_type(SVt_PV);
SvPV_set(value, (char *) he->refcounted_he_data + 1);
SvCUR_set(value, he->refcounted_he_val.refcounted_he_u_len);
/* This stops anything trying to free it */
/*
=for apidoc refcounted_he_chain_2hv
-Generates an returns a C<HV *> by walking up the tree starting at the passed
+Generates and returns a C<HV *> by walking up the tree starting at the passed
in C<struct refcounted_he *>.
=cut
Perl_refcounted_he_fetch(pTHX_ const struct refcounted_he *chain, SV *keysv,
const char *key, STRLEN klen, int flags, U32 hash)
{
+ 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;
#else
if (hash != HEK_HASH(chain->refcounted_he_hek))
continue;
- if (klen != HEK_LEN(chain->refcounted_he_hek))
+ if (klen != (STRLEN)HEK_LEN(chain->refcounted_he_hek))
continue;
if (memNE(HEK_KEY(chain->refcounted_he_hek),key,klen))
continue;
flags = value_type;
#ifdef USE_ITHREADS
- he = PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
- + key_len
- + key_offset);
+ he = (struct refcounted_he*)
+ PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
+ + key_len
+ + key_offset);
#else
- he = PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
- + key_offset);
+ he = (struct refcounted_he*)
+ PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
+ + key_offset);
#endif
void
Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) {
+ dVAR;
PERL_UNUSED_CONTEXT;
while (he) {
withflags++;
if (HeKWASUTF8(entry)) {
PerlIO_printf(Perl_debug_log,
- "hash key has both WASUFT8 and UTF8: '%.*s'\n",
+ "hash key has both WASUTF8 and UTF8: '%.*s'\n",
(int) HeKLEN(entry), HeKEY(entry));
bad = 1;
}