X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=hv.c;h=79702fd98e462fb87647691d692a6a319ae01863;hb=dc053c64f31dbaaf949e0073647513fa42a4d569;hp=e560ba7a8ebd881b8d7f4f2e2354299b792b97e9;hpb=263cb4a6f8ed72054b3a96de216b5a39651a5ec9;p=p5sagit%2Fp5-mst-13.2.git diff --git a/hv.c b/hv.c index e560ba7..79702fd 100644 --- a/hv.c +++ b/hv.c @@ -1,7 +1,7 @@ /* hv.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, 2005, 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. @@ -39,14 +39,14 @@ static const char S_strtab_error[] STATIC void S_more_he(pTHX) { + dVAR; HE* he; HE* heend; - Newx(he, PERL_ARENA_SIZE/sizeof(HE), HE); - HeNEXT(he) = (HE*) PL_body_arenaroots[HE_SVSLOT]; - PL_body_arenaroots[HE_SVSLOT] = he; + + 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; + PL_body_roots[HE_SVSLOT] = he; while (he < heend) { HeNEXT(he) = (HE*)(he + 1); he++; @@ -64,25 +64,23 @@ S_more_he(pTHX) STATIC HE* S_new_he(pTHX) { + dVAR; 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 @@ -90,7 +88,7 @@ S_new_he(pTHX) #endif STATIC HEK * -S_save_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags) +S_save_hek_flags(const char *str, I32 len, U32 hash, int flags) { const int flags_masked = flags & HVhek_MASK; char *k; @@ -102,7 +100,7 @@ S_save_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags) HEK_KEY(hek)[len] = 0; HEK_LEN(hek) = len; HEK_HASH(hek) = hash; - HEK_FLAGS(hek) = (unsigned char)flags_masked; + HEK_FLAGS(hek) = (unsigned char)flags_masked | HVhek_UNSHARED; if (flags & HVhek_FREEKEY) Safefree(str); @@ -115,6 +113,7 @@ S_save_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags) void Perl_free_tied_hv_pool(pTHX) { + dVAR; HE *he = PL_hv_fetch_ent_mh; while (he) { HE * const ohe = he; @@ -122,7 +121,7 @@ Perl_free_tied_hv_pool(pTHX) he = HeNEXT(he); del_HE(ohe); } - PL_hv_fetch_ent_mh = Nullhe; + PL_hv_fetch_ent_mh = NULL; } #if defined(USE_ITHREADS) @@ -152,7 +151,7 @@ Perl_he_dup(pTHX_ const HE *e, bool shared, CLONE_PARAMS* param) HE *ret; if (!e) - return Nullhe; + return NULL; /* look for it in the table first */ ret = (HE*)ptr_table_fetch(PL_ptr_table, e); if (ret) @@ -211,7 +210,7 @@ S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen, 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 @@ -369,7 +368,7 @@ Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 lval) } hek = hv_fetch_common (hv, NULL, key, klen, flags, lval ? (HV_FETCH_JUST_SV | HV_FETCH_LVALUE) : HV_FETCH_JUST_SV, - Nullsv, 0); + NULL, 0); return hek ? &HeVAL(hek) : NULL; } @@ -414,7 +413,7 @@ HE * Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash) { return hv_fetch_common(hv, keysv, NULL, 0, 0, - (lval ? HV_FETCH_LVALUE : 0), Nullsv, hash); + (lval ? HV_FETCH_LVALUE : 0), NULL, hash); } STATIC HE * @@ -430,9 +429,11 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, int masked_flags; if (!hv) - return 0; + 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); @@ -444,14 +445,11 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN 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 (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 HV_FETCH_JUST_SV is true. */ - if (!keysv) { keysv = newSVpvn(key, klen); if (is_utf8) { @@ -460,7 +458,8 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, } 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; @@ -472,7 +471,7 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, Newx(k, HEK_BASESIZE + sizeof(SV*), char); HeKEY_hek(entry) = (HEK*)k; } - HeNEXT(entry) = Nullhe; + HeNEXT(entry) = NULL; HeSVKEY_set(entry, keysv); HeVAL(entry) = sv; sv_upgrade(sv, SVt_PVLV); @@ -496,10 +495,10 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, 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, Nullsv, nkey, klen, + entry = hv_fetch_common(hv, NULL, nkey, klen, HVhek_FREEKEY, /* free nkey */ 0 /* non-LVAL fetch */, - Nullsv /* no value */, + NULL /* no value */, 0 /* compute hash */); if (!entry && (action & HV_FETCH_LVALUE)) { /* This call will free key if necessary. @@ -507,7 +506,7 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, call optimise. */ entry = hv_fetch_common(hv, keysv, key, klen, flags, HV_FETCH_ISSTORE, - NEWSV(61,0), hash); + newSV(0), hash); } else { if (flags & HVhek_FREEKEY) Safefree(key); @@ -550,7 +549,7 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, /* Will need to free this, so set FREEKEY flag. */ key = savepvn(key,klen); key = (const char*)strupr((char*)key); - is_utf8 = 0; + is_utf8 = FALSE; hash = 0; keysv = 0; @@ -581,10 +580,10 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, } TAINT_IF(save_taint); - if (!HvARRAY(hv) && !needs_store) { + if (!needs_store) { if (flags & HVhek_FREEKEY) Safefree(key); - return Nullhe; + return NULL; } #ifdef ENV_IS_CASELESS else if (mg_find((SV*)hv, PERL_MAGIC_env)) { @@ -593,7 +592,7 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, /* Will need to free this, so set FREEKEY flag. */ key = savepvn(key,klen); key = (const char*)strupr((char*)key); - is_utf8 = 0; + is_utf8 = FALSE; hash = 0; keysv = 0; @@ -635,7 +634,7 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, } if (is_utf8) { - char * const keysave = (char * const)key; + char * const keysave = (char *)key; key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8); if (is_utf8) flags |= HVhek_UTF8; @@ -667,7 +666,7 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, masked_flags = (flags & HVhek_MASK); #ifdef DYNAMIC_ENV_FETCH - if (!HvARRAY(hv)) entry = Null(HE*); + if (!HvARRAY(hv)) entry = NULL; else #endif { @@ -693,7 +692,7 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, /* Need to swap the key we have for a key with the flags we need. As keys are shared we can't just write to the flag, so we share the new one, unshare the old one. */ - HEK *new_hek = share_hek_flags(key, klen, hash, + HEK * const new_hek = share_hek_flags(key, klen, hash, masked_flags); unshare_hek (HeKEY_hek(entry)); HeKEY_hek(entry) = new_hek; @@ -727,7 +726,7 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, break; } /* LVAL fetch which actaully needs a store. */ - val = NEWSV(61,0); + val = newSV(0); HvPLACEHOLDERS(hv)--; } else { /* store */ @@ -774,7 +773,7 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, return 0; } if (action & HV_FETCH_LVALUE) { - val = NEWSV(61,0); + val = newSV(0); if (SvMAGICAL(hv)) { /* At this point the old hv_fetch code would call to hv_store, which in turn might do some tied magic. So we need to make that @@ -829,7 +828,7 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, { const HE *counter = HeNEXT(entry); - xhv->xhv_keys++; /* HvKEYS(hv)++ */ + xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */ if (!counter) { /* initial entry? */ xhv->xhv_fill++; /* HvFILL(hv)++ */ } else if (xhv->xhv_keys > (IV)xhv->xhv_max) { @@ -856,7 +855,7 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, } STATIC void -S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store) +S_hv_magic_check(HV *hv, bool *needs_copy, bool *needs_store) { const MAGIC *mg = SvMAGIC(hv); *needs_copy = FALSE; @@ -917,13 +916,14 @@ SV * Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 flags) { STRLEN klen; - int k_flags = 0; + int k_flags; if (klen_i32 < 0) { klen = -klen_i32; - k_flags |= HVhek_UTF8; + k_flags = HVhek_UTF8; } else { klen = klen_i32; + k_flags = 0; } return hv_delete_common(hv, NULL, key, klen, k_flags, flags, 0); } @@ -955,14 +955,15 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, register HE *entry; register HE **oentry; HE *const *first_entry; - SV *sv; bool is_utf8; int masked_flags; if (!hv) - return Nullsv; + 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); @@ -978,9 +979,10 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, hv_magic_check (hv, &needs_copy, &needs_store); if (needs_copy) { + SV *sv; entry = hv_fetch_common(hv, keysv, key, klen, k_flags & ~HVhek_FREEKEY, HV_FETCH_LVALUE, - Nullsv, hash); + NULL, hash); sv = entry ? HeVAL(entry) : NULL; if (sv) { if (SvMAGICAL(sv)) { @@ -992,7 +994,7 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, sv_unmagic(sv, PERL_MAGIC_tiedelem); return sv; } - return Nullsv; /* element cannot be deleted */ + return NULL; /* element cannot be deleted */ } #ifdef ENV_IS_CASELESS else if (mg_find((SV*)hv, PERL_MAGIC_env)) { @@ -1012,7 +1014,7 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, } xhv = (XPVHV*)SvANY(hv); if (!HvARRAY(hv)) - return Nullsv; + return NULL; if (is_utf8) { const char * const keysave = key; @@ -1048,6 +1050,7 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, first_entry = oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; entry = *oentry; for (; entry; oentry = &HeNEXT(entry), entry = *oentry) { + SV *sv; if (HeHASH(entry) != hash) /* strings can't be equal */ continue; if (HeKLEN(entry) != (I32)klen) @@ -1064,14 +1067,13 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, } /* if placeholder is here, it's already been deleted.... */ - if (HeVAL(entry) == &PL_sv_placeholder) - { - if (k_flags & HVhek_FREEKEY) - Safefree(key); - return Nullsv; + if (HeVAL(entry) == &PL_sv_placeholder) { + if (k_flags & HVhek_FREEKEY) + Safefree(key); + return NULL; } - else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) { - S_hv_notallowed(aTHX_ k_flags, key, klen, + if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) { + hv_notallowed(k_flags, key, klen, "Attempt to delete readonly key '%"SVf"' from" " a restricted hash"); } @@ -1079,7 +1081,7 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, Safefree(key); if (d_flags & G_DISCARD) - sv = Nullsv; + sv = NULL; else { sv = sv_2mortal(HeVAL(entry)); HeVAL(entry) = &PL_sv_placeholder; @@ -1106,26 +1108,27 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, HvLAZYDEL_on(hv); else hv_free_ent(hv, entry); - xhv->xhv_keys--; /* HvKEYS(hv)-- */ + xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */ if (xhv->xhv_keys == 0) HvHASKFLAGS_off(hv); } return sv; } if (SvREADONLY(hv)) { - S_hv_notallowed(aTHX_ k_flags, key, klen, + hv_notallowed(k_flags, key, klen, "Attempt to delete disallowed key '%"SVf"' from" " a restricted hash"); } if (k_flags & HVhek_FREEKEY) Safefree(key); - return Nullsv; + return NULL; } STATIC void S_hsplit(pTHX_ HV *hv) { + dVAR; register XPVHV* xhv = (XPVHV*)SvANY(hv); const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */ register I32 newsize = oldsize * 2; @@ -1137,7 +1140,7 @@ S_hsplit(pTHX_ HV *hv) 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, @@ -1233,7 +1236,7 @@ S_hsplit(pTHX_ HV *hv) } /* 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; @@ -1295,6 +1298,7 @@ S_hsplit(pTHX_ HV *hv) void Perl_hv_ksplit(pTHX_ HV *hv, IV newmax) { + dVAR; register XPVHV* xhv = (XPVHV*)SvANY(hv); const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */ register I32 newsize; @@ -1363,8 +1367,9 @@ Perl_hv_ksplit(pTHX_ HV *hv, IV newmax) if (!*aep) /* non-existent */ continue; for (oentry = aep, entry = *aep; entry; entry = *oentry) { - register I32 j; - if ((j = (HeHASH(entry) & newsize)) != i) { + register I32 j = (HeHASH(entry) & newsize); + + if (j != i) { j -= i; *oentry = HeNEXT(entry); if (!(HeNEXT(entry) = aep[j])) @@ -1392,12 +1397,9 @@ HV * Perl_newHV(pTHX) { register XPVHV* xhv; - HV * const hv = (HV*)NEWSV(502,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 @@ -1428,7 +1430,7 @@ Perl_newHVhv(pTHX_ HV *ohv) /* In each bucket... */ for (i = 0; i <= hv_max; i++) { - HE *prev = NULL, *ent = NULL; + HE *prev = NULL; HE *oent = oents[i]; if (!oent) { @@ -1442,8 +1444,8 @@ Perl_newHVhv(pTHX_ HV *ohv) const char * const key = HeKEY(oent); const STRLEN len = HeKLEN(oent); const int flags = HeKFLAGS(oent); + HE * const ent = new_HE(); - ent = new_HE(); HeVAL(ent) = newSVsv(HeVAL(oent)); HeKEY_hek(ent) = shared ? share_hek_flags(key, len, hash, flags) @@ -1486,16 +1488,50 @@ Perl_newHVhv(pTHX_ HV *ohv) return hv; } +/* A rather specialised version of newHVhv for copying %^H, ensuring all the + magic stays on it. */ +HV * +Perl_hv_copy_hints_hv(pTHX_ HV *const ohv) +{ + HV * const hv = newHV(); + STRLEN hv_fill; + + if (ohv && (hv_fill = HvFILL(ohv))) { + STRLEN hv_max = HvMAX(ohv); + HE *entry; + const I32 riter = HvRITER_get(ohv); + HE * const eiter = HvEITER_get(ohv); + + 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_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)); + } + HvRITER_set(ohv, riter); + HvEITER_set(ohv, eiter); + } + hv_magic(hv, NULL, PERL_MAGIC_hints); + return hv; +} + void Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry) { + dVAR; SV *val; if (!entry) return; val = HeVAL(entry); if (val && isGV(val) && GvCVu(val) && HvNAME_get(hv)) - PL_sub_generation++; /* may be deletion of method from stash */ + mro_method_changed_in(hv); /* deletion of method from stash */ SvREFCNT_dec(val); if (HeKLEN(entry) == HEf_SVKEY) { SvREFCNT_dec(HeKEY_sv(entry)); @@ -1511,6 +1547,7 @@ Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry) void Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry) { + dVAR; if (!entry) return; /* SvREFCNT_inc to counter the SvREFCNT_dec in hv_free_ent */ @@ -1550,10 +1587,10 @@ Perl_hv_clear(pTHX_ HV *hv) /* not already placeholder */ if (HeVAL(entry) != &PL_sv_placeholder) { if (HeVAL(entry) && SvREADONLY(HeVAL(entry))) { - SV* keysv = hv_iterkeysv(entry); + SV* const keysv = hv_iterkeysv(entry); Perl_croak(aTHX_ - "Attempt to delete readonly key '%"SVf"' from a restricted hash", - keysv); + "Attempt to delete readonly key '%"SVf"' from a restricted hash", + (void*)keysv); } SvREFCNT_dec(HeVAL(entry)); HeVAL(entry) = &PL_sv_placeholder; @@ -1567,8 +1604,7 @@ Perl_hv_clear(pTHX_ HV *hv) hfreeentries(hv); HvPLACEHOLDERS_set(hv, 0); if (HvARRAY(hv)) - (void)memzero(HvARRAY(hv), - (xhv->xhv_max+1 /* HvMAX(hv)+1 */) * sizeof(HE*)); + Zero(HvARRAY(hv), xhv->xhv_max+1 /* HvMAX(hv)+1 */, HE*); if (SvRMAGICAL(hv)) mg_clear((SV*)hv); @@ -1599,7 +1635,16 @@ void Perl_hv_clear_placeholders(pTHX_ HV *hv) { dVAR; - I32 items = (I32)HvPLACEHOLDERS_get(hv); + const U32 items = (U32)HvPLACEHOLDERS_get(hv); + + if (items) + clear_placeholders(hv, items); +} + +static void +S_clear_placeholders(pTHX_ HV *hv, U32 items) +{ + dVAR; I32 i; if (items == 0) @@ -1608,19 +1653,16 @@ Perl_hv_clear_placeholders(pTHX_ HV *hv) i = HvMAX(hv); do { /* Loop down the linked list heads */ - bool first = 1; + bool first = TRUE; HE **oentry = &(HvARRAY(hv))[i]; - HE *entry = *oentry; - - if (!entry) - continue; + HE *entry; - for (; entry; entry = *oentry) { + while ((entry = *oentry)) { if (HeVAL(entry) == &PL_sv_placeholder) { *oentry = HeNEXT(entry); if (first && !*oentry) HvFILL(hv)--; /* This linked list is now empty. */ - if (HvEITER_get(hv)) + if (entry == HvEITER_get(hv)) HvLAZYDEL_on(hv); else hv_free_ent(hv, entry); @@ -1635,7 +1677,7 @@ Perl_hv_clear_placeholders(pTHX_ HV *hv) } } else { oentry = &HeNEXT(entry); - first = 0; + first = FALSE; } } } while (--i >= 0); @@ -1647,85 +1689,146 @@ Perl_hv_clear_placeholders(pTHX_ HV *hv) STATIC void S_hfreeentries(pTHX_ HV *hv) { - register HE **array; - register HE *entry; - I32 riter; - I32 max; - struct xpvhv_aux *iter; + /* This is the array that we're going to restore */ + HE **const orig_array = HvARRAY(hv); + HEK *name; + int attempts = 100; - if (!HvARRAY(hv)) + if (!orig_array) return; - iter = SvOOK(hv) ? HvAUX(hv) : 0; + if (SvOOK(hv)) { + /* If the hash is actually a symbol table with a name, look after the + name. */ + struct xpvhv_aux *iter = HvAUX(hv); - /* If there are weak references to this HV, we need to avoid freeing them - up here. - */ - if (iter) { - if (iter->xhv_backreferences) { - /* So donate them to regular backref magic to keep them safe. The - sv_magic will increase the reference count of the AV, so we need - to drop it first. */ - SvREFCNT_dec(iter->xhv_backreferences); - sv_magic((SV*)hv, (SV*)iter->xhv_backreferences, - PERL_MAGIC_backref, NULL, 0); - iter->xhv_backreferences = 0; - } + name = iter->xhv_name; + iter->xhv_name = NULL; + } else { + name = NULL; } - riter = 0; - max = HvMAX(hv); - array = HvARRAY(hv); - /* make everyone else think the array is empty, so that the destructors - * called for freed entries can't recusively mess with us */ - HvARRAY(hv) = Null(HE**); - SvFLAGS(hv) &= ~SVf_OOK; + /* 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 + array to the new HvARRAY, and try again. */ + + while (1) { + /* This is the one we're going to try to empty. First time round + it's the original array. (Hopefully there will only be 1 time + round) */ + HE ** const array = HvARRAY(hv); + I32 i = HvMAX(hv); - HvFILL(hv) = 0; - ((XPVHV*) SvANY(hv))->xhv_keys = 0; + /* Because we have taken xhv_name out, the only allocated pointer + in the aux structure that might exist is the backreference array. + */ - entry = array[0]; - for (;;) { - if (entry) { - register HE * const oentry = entry; - entry = HeNEXT(entry); - hv_free_ent(hv, oentry); + if (SvOOK(hv)) { + HE *entry; + struct mro_meta *meta; + struct xpvhv_aux *iter = HvAUX(hv); + /* If there are weak references to this HV, we need to avoid + freeing them up here. In particular we need to keep the AV + visible as what we're deleting might well have weak references + back to this HV, so the for loop below may well trigger + the removal of backreferences from this array. */ + + if (iter->xhv_backreferences) { + /* So donate them to regular backref magic to keep them safe. + The sv_magic will increase the reference count of the AV, + so we need to drop it first. */ + SvREFCNT_dec(iter->xhv_backreferences); + if (AvFILLp(iter->xhv_backreferences) == -1) { + /* Turns out that the array is empty. Just free it. */ + SvREFCNT_dec(iter->xhv_backreferences); + + } else { + sv_magic((SV*)hv, (SV*)iter->xhv_backreferences, + PERL_MAGIC_backref, NULL, 0); + } + iter->xhv_backreferences = NULL; + } + + entry = iter->xhv_eiter; /* HvEITER(hv) */ + if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */ + HvLAZYDEL_off(hv); + hv_free_ent(hv, entry); + } + iter->xhv_riter = -1; /* HvRITER(hv) = -1 */ + iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */ + + if((meta = iter->xhv_mro_meta)) { + if(meta->mro_linear_dfs) SvREFCNT_dec(meta->mro_linear_dfs); + if(meta->mro_linear_c3) SvREFCNT_dec(meta->mro_linear_c3); + if(meta->mro_isarev) SvREFCNT_dec(meta->mro_isarev); + if(meta->mro_nextmethod) SvREFCNT_dec(meta->mro_nextmethod); + Safefree(meta); + iter->xhv_mro_meta = NULL; + } + + /* There are now no allocated pointers in the aux structure. */ + + SvFLAGS(hv) &= ~SVf_OOK; /* Goodbye, aux structure. */ + /* What aux structure? */ } - if (!entry) { - if (++riter > max) - break; - entry = array[riter]; + + /* make everyone else think the array is empty, so that the destructors + * called for freed entries can't recusively mess with us */ + HvARRAY(hv) = NULL; + HvFILL(hv) = 0; + ((XPVHV*) SvANY(hv))->xhv_keys = 0; + + + do { + /* Loop down the linked list heads */ + HE *entry = array[i]; + + while (entry) { + register HE * const oentry = entry; + entry = HeNEXT(entry); + hv_free_ent(hv, oentry); + } + } while (--i >= 0); + + /* As there are no allocated pointers in the aux structure, it's now + safe to free the array we just cleaned up, if it's not the one we're + going to put back. */ + if (array != orig_array) { + Safefree(array); } - } - if (SvOOK(hv)) { - /* Someone attempted to iterate or set the hash name while we had - the array set to 0. */ - assert(HvARRAY(hv)); + if (!HvARRAY(hv)) { + /* Good. No-one added anything this time round. */ + break; + } - if (HvAUX(hv)->xhv_name) - unshare_hek_or_pvn(HvAUX(hv)->xhv_name, 0, 0, 0); - /* SvOOK_off calls sv_backoff, which isn't correct. */ + if (SvOOK(hv)) { + /* Someone attempted to iterate or set the hash name while we had + the array set to 0. We'll catch backferences on the next time + round the while loop. */ + assert(HvARRAY(hv)); - Safefree(HvARRAY(hv)); - HvARRAY(hv) = 0; - SvFLAGS(hv) &= ~SVf_OOK; - } + if (HvAUX(hv)->xhv_name) { + unshare_hek_or_pvn(HvAUX(hv)->xhv_name, 0, 0, 0); + } + } - /* FIXME - things will still go horribly wrong (or at least leak) if - people attempt to add elements to the hash while we're undef()ing it */ - if (iter) { - entry = iter->xhv_eiter; /* HvEITER(hv) */ - if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */ - HvLAZYDEL_off(hv); - hv_free_ent(hv, entry); + if (--attempts == 0) { + Perl_die(aTHX_ "panic: hfreeentries failed to free hash - something is repeatedly re-creating entries"); } - iter->xhv_riter = -1; /* HvRITER(hv) = -1 */ - iter->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */ - SvFLAGS(hv) |= SVf_OOK; } + + HvARRAY(hv) = orig_array; - HvARRAY(hv) = array; + /* If the hash was actually a symbol table, put the name back. */ + if (name) { + /* We have restored the original array. If name is non-NULL, then + the original array had an aux structure at the end. So this is + valid: */ + SvFLAGS(hv) |= SVf_OOK; + HvAUX(hv)->xhv_name = name; + } } /* @@ -1739,6 +1842,7 @@ Undefines the hash. void Perl_hv_undef(pTHX_ HV *hv) { + dVAR; register XPVHV* xhv; const char *name; @@ -1750,7 +1854,7 @@ Perl_hv_undef(pTHX_ HV *hv) if ((name = HvNAME_get(hv))) { if(PL_stashcache) hv_delete(PL_stashcache, name, HvNAMELEN_get(hv), G_DISCARD); - hv_name_set(hv, Nullch, 0, 0); + hv_name_set(hv, NULL, 0, 0); } SvFLAGS(hv) &= ~SVf_OOK; Safefree(HvARRAY(hv)); @@ -1763,7 +1867,7 @@ Perl_hv_undef(pTHX_ HV *hv) } static struct xpvhv_aux* -S_hv_auxinit(pTHX_ HV *hv) { +S_hv_auxinit(HV *hv) { struct xpvhv_aux *iter; char *array; @@ -1781,9 +1885,10 @@ S_hv_auxinit(pTHX_ HV *hv) { iter = HvAUX(hv); iter->xhv_riter = -1; /* HvRITER(hv) = -1 */ - iter->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */ + iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */ iter->xhv_name = 0; iter->xhv_backreferences = 0; + iter->xhv_mro_meta = NULL; return iter; } @@ -1809,16 +1914,16 @@ Perl_hv_iterinit(pTHX_ HV *hv) Perl_croak(aTHX_ "Bad hash"); if (SvOOK(hv)) { - struct xpvhv_aux *iter = HvAUX(hv); + struct xpvhv_aux * const iter = HvAUX(hv); HE * const entry = iter->xhv_eiter; /* HvEITER(hv) */ if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */ HvLAZYDEL_off(hv); hv_free_ent(hv, entry); } iter->xhv_riter = -1; /* HvRITER(hv) = -1 */ - iter->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */ + iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */ } else { - S_hv_auxinit(aTHX_ hv); + hv_auxinit(hv); } /* used to be xhv->xhv_fill before 5.004_65 */ @@ -1832,7 +1937,7 @@ Perl_hv_riter_p(pTHX_ HV *hv) { if (!hv) Perl_croak(aTHX_ "Bad hash"); - iter = SvOOK(hv) ? HvAUX(hv) : S_hv_auxinit(aTHX_ hv); + iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv); return &(iter->xhv_riter); } @@ -1843,7 +1948,7 @@ Perl_hv_eiter_p(pTHX_ HV *hv) { if (!hv) Perl_croak(aTHX_ "Bad hash"); - iter = SvOOK(hv) ? HvAUX(hv) : S_hv_auxinit(aTHX_ hv); + iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv); return &(iter->xhv_eiter); } @@ -1860,7 +1965,7 @@ Perl_hv_riter_set(pTHX_ HV *hv, I32 riter) { if (riter == -1) return; - iter = S_hv_auxinit(aTHX_ hv); + iter = hv_auxinit(hv); } iter->xhv_riter = riter; } @@ -1880,19 +1985,23 @@ Perl_hv_eiter_set(pTHX_ HV *hv, HE *eiter) { if (!eiter) return; - iter = S_hv_auxinit(aTHX_ hv); + iter = hv_auxinit(hv); } iter->xhv_eiter = eiter; } void -Perl_hv_name_set(pTHX_ HV *hv, const char *name, I32 len, int flags) +Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags) { + dVAR; struct xpvhv_aux *iter; U32 hash; PERL_UNUSED_ARG(flags); + if (len > I32_MAX) + Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len); + if (SvOOK(hv)) { iter = HvAUX(hv); if (iter->xhv_name) { @@ -1902,7 +2011,7 @@ Perl_hv_name_set(pTHX_ HV *hv, const char *name, I32 len, int flags) if (name == 0) return; - iter = S_hv_auxinit(aTHX_ hv); + iter = hv_auxinit(hv); } PERL_HASH(hash, name, len); iter->xhv_name = name ? share_hek(name, len, hash) : 0; @@ -1910,9 +2019,8 @@ Perl_hv_name_set(pTHX_ HV *hv, const char *name, I32 len, int flags) AV ** Perl_hv_backreferences_p(pTHX_ HV *hv) { - struct xpvhv_aux *iter; - - iter = SvOOK(hv) ? HvAUX(hv) : S_hv_auxinit(aTHX_ hv); + struct xpvhv_aux * const iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv); + PERL_UNUSED_CONTEXT; return &(iter->xhv_backreferences); } @@ -1972,6 +2080,7 @@ Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags) if (!hv) Perl_croak(aTHX_ "Bad hash"); + xhv = (XPVHV*)SvANY(hv); if (!SvOOK(hv)) { @@ -1983,39 +2092,40 @@ Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags) 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(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(HE*); /* HvEITER(hv) = Null(HE*) */ - return Null(HE*); + 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; + } } -#ifdef DYNAMIC_ENV_FETCH /* set up %ENV for iteration */ +#if defined(DYNAMIC_ENV_FETCH) && !defined(__riscos__) /* set up %ENV for iteration */ if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) { prime_env_iter(); #ifdef VMS @@ -2074,7 +2184,7 @@ Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags) } /*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; @@ -2190,6 +2300,7 @@ Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash) void Perl_unshare_hek(pTHX_ HEK *hek) { + assert(hek); unshare_hek_or_pvn(hek, NULL, 0, 0); } @@ -2200,15 +2311,15 @@ Perl_unshare_hek(pTHX_ HEK *hek) STATIC void S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash) { + dVAR; register XPVHV* xhv; HE *entry; register HE **oentry; HE **first; - bool found = 0; bool is_utf8 = FALSE; int k_flags = 0; const char * const save = str; - struct shared_he *he = 0; + struct shared_he *he = NULL; if (hek) { /* Find the shared he which is just before us in memory. */ @@ -2221,8 +2332,8 @@ S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash) assert (he->shared_he_he.hent_hek == hek); LOCK_STRTAB_MUTEX; - if (he->shared_he_he.hent_val - 1) { - --he->shared_he_he.hent_val; + if (he->shared_he_he.he_valu.hent_refcount - 1) { + --he->shared_he_he.he_valu.hent_refcount; UNLOCK_STRTAB_MUTEX; return; } @@ -2241,9 +2352,9 @@ S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash) k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY; } - /* what follows is the moral equivalent of: + /* what follows was the moral equivalent of: if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) { - if (--*Svp == Nullsv) + if (--*Svp == NULL) hv_delete(PL_strtab, str, len, G_DISCARD, hash); } */ xhv = (XPVHV*)SvANY(PL_strtab); @@ -2253,10 +2364,8 @@ S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash) if (he) { const HE *const he_he = &(he->shared_he_he); for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) { - if (entry != he_he) - continue; - found = 1; - break; + if (entry == he_he) + break; } } else { const int flags_masked = k_flags & HVhek_MASK; @@ -2269,25 +2378,24 @@ S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash) continue; if (HeKFLAGS(entry) != flags_masked) continue; - found = 1; break; } } - if (found) { - if (--HeVAL(entry) == Nullsv) { + if (entry) { + if (--entry->he_valu.hent_refcount == 0) { *oentry = HeNEXT(entry); if (!*first) { /* There are now no entries in our slot. */ xhv->xhv_fill--; /* HvFILL(hv)-- */ } Safefree(entry); - xhv->xhv_keys--; /* HvKEYS(hv)-- */ + xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */ } } UNLOCK_STRTAB_MUTEX; - if (!found && ckWARN_d(WARN_INTERNAL)) + if (!entry && ckWARN_d(WARN_INTERNAL)) Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Attempt to free non-existent shared string '%s'%s" pTHX__FORMAT, @@ -2331,6 +2439,7 @@ Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash) STATIC HEK * S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags) { + dVAR; register HE *entry; const int flags_masked = flags & HVhek_MASK; const U32 hindex = hash & (I32) HvMAX(PL_strtab); @@ -2338,7 +2447,7 @@ S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags) /* what follows is the moral equivalent of: if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE))) - hv_store(PL_strtab, str, len, Nullsv, hash); + hv_store(PL_strtab, str, len, NULL, hash); Can't rehash the shared string table, so not sure if it's worth counting the number of entries in the linked list @@ -2390,11 +2499,11 @@ S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags) /* Still "point" to the HEK, so that other code need not know what we're up to. */ HeKEY_hek(entry) = hek; - HeVAL(entry) = Nullsv; + entry->he_valu.hent_refcount = 0; HeNEXT(entry) = next; *head = entry; - xhv->xhv_keys++; /* HvKEYS(hv)++ */ + xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */ if (!next) { /* initial entry? */ xhv->xhv_fill++; /* HvFILL(hv)++ */ } else if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) { @@ -2402,7 +2511,7 @@ S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags) } } - ++HeVAL(entry); /* use value slot as REFCNT */ + ++entry->he_valu.hent_refcount; UNLOCK_STRTAB_MUTEX; if (flags & HVhek_FREEKEY) @@ -2411,6 +2520,24 @@ S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags) 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) { @@ -2452,6 +2579,350 @@ Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph) /* else we don't need to add magic to record 0 placeholders. */ } +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: + value = newSV(0); + break; + case HVrhek_delete: + value = &PL_sv_placeholder; + break; + case HVrhek_IV: + value = newSViv(he->refcounted_he_val.refcounted_he_u_iv); + break; + case HVrhek_UV: + value = newSVuv(he->refcounted_he_val.refcounted_he_u_uv); + break; + case HVrhek_PV: + case HVrhek_PV_UTF8: + /* Create a string SV that directly points to the bytes in our + structure. */ + 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 */ + SvLEN_set(value, 0); + SvPOK_on(value); + SvREADONLY_on(value); + if ((he->refcounted_he_data[0] & HVrhek_typemask) == HVrhek_PV_UTF8) + SvUTF8_on(value); + break; + default: + Perl_croak(aTHX_ "panic: refcounted_he_value bad flags %x", + he->refcounted_he_data[0]); + } + return value; +} + +/* +=for apidoc refcounted_he_chain_2hv + +Generates and returns a C by walking up the tree starting at the passed +in C. + +=cut +*/ +HV * +Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain) +{ + dVAR; + HV *hv = newHV(); + U32 placeholders = 0; + /* We could chase the chain once to get an idea of the number of keys, + and call ksplit. But for now we'll make a potentially inefficient + hash with only 8 entries in its array. */ + const U32 max = HvMAX(hv); + + if (!HvARRAY(hv)) { + char *array; + Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(max + 1), char); + HvARRAY(hv) = (HE**)array; + } + + while (chain) { +#ifdef USE_ITHREADS + U32 hash = chain->refcounted_he_hash; +#else + U32 hash = HEK_HASH(chain->refcounted_he_hek); +#endif + HE **oentry = &((HvARRAY(hv))[hash & max]); + HE *entry = *oentry; + SV *value; + + for (; entry; entry = HeNEXT(entry)) { + if (HeHASH(entry) == hash) { + /* We might have a duplicate key here. If so, entry is older + than the key we've already put in the hash, so if they are + the same, skip adding entry. */ +#ifdef USE_ITHREADS + const STRLEN klen = HeKLEN(entry); + const char *const key = HeKEY(entry); + if (klen == chain->refcounted_he_keylen + && (!!HeKUTF8(entry) + == !!(chain->refcounted_he_data[0] & HVhek_UTF8)) + && memEQ(key, REF_HE_KEY(chain), klen)) + goto next_please; +#else + if (HeKEY_hek(entry) == chain->refcounted_he_hek) + goto next_please; + if (HeKLEN(entry) == HEK_LEN(chain->refcounted_he_hek) + && HeKUTF8(entry) == HEK_UTF8(chain->refcounted_he_hek) + && memEQ(HeKEY(entry), HEK_KEY(chain->refcounted_he_hek), + HeKLEN(entry))) + goto next_please; +#endif + } + } + assert (!entry); + entry = new_HE(); + +#ifdef USE_ITHREADS + HeKEY_hek(entry) + = share_hek_flags(REF_HE_KEY(chain), + chain->refcounted_he_keylen, + chain->refcounted_he_hash, + (chain->refcounted_he_data[0] + & (HVhek_UTF8|HVhek_WASUTF8))); +#else + HeKEY_hek(entry) = share_hek_hek(chain->refcounted_he_hek); +#endif + value = refcounted_he_value(chain); + if (value == &PL_sv_placeholder) + placeholders++; + HeVAL(entry) = value; + + /* Link it into the chain. */ + HeNEXT(entry) = *oentry; + if (!HeNEXT(entry)) { + /* initial entry. */ + HvFILL(hv)++; + } + *oentry = entry; + + HvTOTALKEYS(hv)++; + + next_please: + chain = chain->refcounted_he_next; + } + + if (placeholders) { + clear_placeholders(hv, placeholders); + HvTOTALKEYS(hv) -= placeholders; + } + + /* We could check in the loop to see if we encounter any keys with key + flags, but it's probably not worth it, as this per-hash flag is only + really meant as an optimisation for things like Storable. */ + HvHASKFLAGS_on(hv); + DEBUG_A(Perl_hv_assert(aTHX_ hv)); + + return hv; +} + +SV * +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; + bool is_utf8; + + if (keysv) { + if (flags & HVhek_FREEKEY) + Safefree(key); + key = SvPV_const(keysv, klen); + flags = 0; + is_utf8 = (SvUTF8(keysv) != 0); + } else { + is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE); + } + + if (!hash) { + if (keysv && (SvIsCOW_shared_hash(keysv))) { + hash = SvSHARED_HASH(keysv); + } else { + PERL_HASH(hash, key, klen); + } + } + + for (; chain; chain = chain->refcounted_he_next) { +#ifdef USE_ITHREADS + if (hash != chain->refcounted_he_hash) + continue; + if (klen != chain->refcounted_he_keylen) + continue; + if (memNE(REF_HE_KEY(chain),key,klen)) + continue; + if (!!is_utf8 != !!(chain->refcounted_he_data[0] & HVhek_UTF8)) + continue; +#else + if (hash != HEK_HASH(chain->refcounted_he_hek)) + continue; + if (klen != (STRLEN)HEK_LEN(chain->refcounted_he_hek)) + continue; + if (memNE(HEK_KEY(chain->refcounted_he_hek),key,klen)) + continue; + if (!!is_utf8 != !!HEK_UTF8(chain->refcounted_he_hek)) + continue; +#endif + + value = sv_2mortal(refcounted_he_value(chain)); + break; + } + + if (flags & HVhek_FREEKEY) + Safefree(key); + + return value; +} + +/* +=for apidoc refcounted_he_new + +Creates a new C. As S is copied, and value is +stored in a compact form, all references remain the property of the caller. +The C is returned with a reference count of 1. + +=cut +*/ + +struct refcounted_he * +Perl_refcounted_he_new(pTHX_ struct refcounted_he *const parent, + SV *const key, SV *const value) { + dVAR; + struct refcounted_he *he; + STRLEN key_len; + const char *key_p = SvPV_const(key, key_len); + STRLEN value_len = 0; + const char *value_p = NULL; + char value_type; + char flags; + STRLEN key_offset; + U32 hash; + bool is_utf8 = SvUTF8(key) ? TRUE : FALSE; + + if (SvPOK(value)) { + value_type = HVrhek_PV; + } else if (SvIOK(value)) { + value_type = HVrhek_IV; + } else if (value == &PL_sv_placeholder) { + value_type = HVrhek_delete; + } else if (!SvOK(value)) { + value_type = HVrhek_undef; + } else { + value_type = HVrhek_PV; + } + + if (value_type == HVrhek_PV) { + value_p = SvPV_const(value, value_len); + key_offset = value_len + 2; + } else { + value_len = 0; + key_offset = 1; + } + +#ifdef USE_ITHREADS + he = (struct refcounted_he*) + PerlMemShared_malloc(sizeof(struct refcounted_he) - 1 + + key_len + + key_offset); +#else + he = (struct refcounted_he*) + PerlMemShared_malloc(sizeof(struct refcounted_he) - 1 + + key_offset); +#endif + + + he->refcounted_he_next = parent; + + if (value_type == HVrhek_PV) { + Copy(value_p, he->refcounted_he_data + 1, value_len + 1, char); + he->refcounted_he_val.refcounted_he_u_len = value_len; + /* Do it this way so that the SvUTF8() test is after the SvPV, in case + the value is overloaded, and doesn't yet have the UTF-8flag set. */ + if (SvUTF8(value)) + value_type = HVrhek_PV_UTF8; + } else if (value_type == HVrhek_IV) { + if (SvUOK(value)) { + he->refcounted_he_val.refcounted_he_u_uv = SvUVX(value); + value_type = HVrhek_UV; + } else { + he->refcounted_he_val.refcounted_he_u_iv = SvIVX(value); + } + } + flags = value_type; + + if (is_utf8) { + /* Hash keys are always stored normalised to (yes) ISO-8859-1. + As we're going to be building hash keys from this value in future, + normalise it now. */ + key_p = (char*)bytes_from_utf8((const U8*)key_p, &key_len, &is_utf8); + flags |= is_utf8 ? HVhek_UTF8 : HVhek_WASUTF8; + } + PERL_HASH(hash, key_p, key_len); + +#ifdef USE_ITHREADS + he->refcounted_he_hash = hash; + he->refcounted_he_keylen = key_len; + Copy(key_p, he->refcounted_he_data + key_offset, key_len, char); +#else + he->refcounted_he_hek = share_hek_flags(key_p, key_len, hash, flags); +#endif + + if (flags & HVhek_WASUTF8) { + /* If it was downgraded from UTF-8, then the pointer returned from + bytes_from_utf8 is an allocated pointer that we must free. */ + Safefree(key_p); + } + + he->refcounted_he_data[0] = flags; + he->refcounted_he_refcnt = 1; + + return he; +} + +/* +=for apidoc refcounted_he_free + +Decrements the reference count of the passed in C +by one. If the reference count reaches zero the structure's memory is freed, +and C iterates onto the parent node. + +=cut +*/ + +void +Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) { + dVAR; + PERL_UNUSED_CONTEXT; + + while (he) { + struct refcounted_he *copy; + U32 new_count; + + HINTS_REFCNT_LOCK; + new_count = --he->refcounted_he_refcnt; + HINTS_REFCNT_UNLOCK; + + if (new_count) { + return; + } + +#ifndef USE_ITHREADS + unshare_hek_or_pvn (he->refcounted_he_hek, 0, 0, 0); +#endif + copy = he; + he = he->refcounted_he_next; + PerlMemShared_free(copy); + } +} + /* =for apidoc hv_assert @@ -2460,68 +2931,71 @@ Check that a hash is in an internally consistent state. =cut */ +#ifdef DEBUGGING + void Perl_hv_assert(pTHX_ HV *hv) { - dVAR; - HE* entry; - int withflags = 0; - int placeholders = 0; - int real = 0; - int bad = 0; - const I32 riter = HvRITER_get(hv); - HE *eiter = HvEITER_get(hv); - - (void)hv_iterinit(hv); - - while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) { - /* sanity check the values */ - if (HeVAL(entry) == &PL_sv_placeholder) { - placeholders++; - } else { - real++; - } - /* sanity check the keys */ - if (HeSVKEY(entry)) { - /* Don't know what to check on SV keys. */ - } else if (HeKUTF8(entry)) { - withflags++; - if (HeKWASUTF8(entry)) { - PerlIO_printf(Perl_debug_log, - "hash key has both WASUFT8 and UTF8: '%.*s'\n", - (int) HeKLEN(entry), HeKEY(entry)); - bad = 1; - } - } else if (HeKWASUTF8(entry)) { - withflags++; - } - } - if (!SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) { - if (HvUSEDKEYS(hv) != real) { - PerlIO_printf(Perl_debug_log, "Count %d key(s), but hash reports %d\n", - (int) real, (int) HvUSEDKEYS(hv)); - bad = 1; - } - if (HvPLACEHOLDERS_get(hv) != placeholders) { - PerlIO_printf(Perl_debug_log, - "Count %d placeholder(s), but hash reports %d\n", - (int) placeholders, (int) HvPLACEHOLDERS_get(hv)); - bad = 1; - } - } - if (withflags && ! HvHASKFLAGS(hv)) { - PerlIO_printf(Perl_debug_log, - "Hash has HASKFLAGS off but I count %d key(s) with flags\n", - withflags); - bad = 1; - } - if (bad) { - sv_dump((SV *)hv); - } - HvRITER_set(hv, riter); /* Restore hash iterator state */ - HvEITER_set(hv, eiter); + dVAR; + HE* entry; + int withflags = 0; + int placeholders = 0; + int real = 0; + int bad = 0; + const I32 riter = HvRITER_get(hv); + HE *eiter = HvEITER_get(hv); + + (void)hv_iterinit(hv); + + while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) { + /* sanity check the values */ + if (HeVAL(entry) == &PL_sv_placeholder) + placeholders++; + else + real++; + /* sanity check the keys */ + if (HeSVKEY(entry)) { + NOOP; /* Don't know what to check on SV keys. */ + } else if (HeKUTF8(entry)) { + withflags++; + if (HeKWASUTF8(entry)) { + PerlIO_printf(Perl_debug_log, + "hash key has both WASUTF8 and UTF8: '%.*s'\n", + (int) HeKLEN(entry), HeKEY(entry)); + bad = 1; + } + } else if (HeKWASUTF8(entry)) + withflags++; + } + if (!SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) { + static const char bad_count[] = "Count %d %s(s), but hash reports %d\n"; + const int nhashkeys = HvUSEDKEYS(hv); + const int nhashplaceholders = HvPLACEHOLDERS_get(hv); + + if (nhashkeys != real) { + PerlIO_printf(Perl_debug_log, bad_count, real, "keys", nhashkeys ); + bad = 1; + } + if (nhashplaceholders != placeholders) { + PerlIO_printf(Perl_debug_log, bad_count, placeholders, "placeholder", nhashplaceholders ); + bad = 1; + } + } + if (withflags && ! HvHASKFLAGS(hv)) { + PerlIO_printf(Perl_debug_log, + "Hash has HASKFLAGS off but I count %d key(s) with flags\n", + withflags); + bad = 1; + } + if (bad) { + sv_dump((SV *)hv); + } + HvRITER_set(hv, riter); /* Restore hash iterator state */ + HvEITER_set(hv, eiter); } +#endif + /* * Local variables: * c-indentation-style: bsd